--  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 :: CHSFrag -> Position
posOf (CHSVerb String
_ Position
pos ) = Position
pos
  posOf (CHSHook CHSHook
hook  ) = forall a. Pos a => a -> Position
posOf CHSHook
hook
  posOf (CHSCPP  String
_ Position
pos ) = Position
pos
  posOf (CHSLine   Position
pos ) = Position
pos
  posOf (CHSC    String
_ Position
pos ) = Position
pos
  posOf (CHSCond [(Ident, [CHSFrag])]
alts Maybe [CHSFrag]
_) = case [(Ident, [CHSFrag])]
alts of
                             (Ident
_, CHSFrag
frag:[CHSFrag]
_):[(Ident, [CHSFrag])]
_ -> forall a. Pos a => a -> Position
posOf CHSFrag
frag
                             [(Ident, [CHSFrag])]
_             -> Position
nopos
  posOf (CHSLang [String]
_ Position
pos)  = Position
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 :: CHSHook -> Position
posOf (CHSImport  Bool
_ Ident
_ String
_         Position
pos) = Position
pos
  posOf (CHSContext Maybe String
_ Maybe String
_ Maybe String
_         Position
pos) = Position
pos
  posOf (CHSType    Ident
_             Position
pos) = Position
pos
  posOf (CHSSizeof  Ident
_             Position
pos) = Position
pos
  posOf (CHSEnum    Ident
_ Maybe Ident
_ CHSTrans
_ Maybe String
_ [Ident]
_     Position
pos) = Position
pos
  posOf (CHSCall    Bool
_ Bool
_ Bool
_ Ident
_ Maybe Ident
_     Position
pos) = Position
pos
  posOf (CHSFun   Bool
_ Bool
_ Bool
_ Ident
_ Maybe Ident
_ Maybe String
_ [CHSParm]
_ CHSParm
_ Position
pos) = Position
pos
  posOf (CHSField   CHSAccess
_ CHSAPath
_           Position
pos) = Position
pos
  posOf (CHSPointer Bool
_ Ident
_ Maybe Ident
_ CHSPtrType
_ Bool
_ Maybe Ident
_   Position
pos) = Position
pos
  posOf (CHSClass   Maybe Ident
_ Ident
_ Ident
_         Position
pos) = Position
pos

-- two hooks are equal if they have the same Haskell name and reference the
-- same C object 
--
instance Eq CHSHook where
  (CHSImport Bool
qual1 Ident
ide1 String
_      Position
_) == :: CHSHook -> CHSHook -> Bool
== (CHSImport Bool
qual2 Ident
ide2 String
_      Position
_) =    
    Bool
qual1 forall a. Eq a => a -> a -> Bool
== Bool
qual2 Bool -> Bool -> Bool
&& Ident
ide1 forall a. Eq a => a -> a -> Bool
== Ident
ide2
  (CHSContext Maybe String
olib1 Maybe String
opref1 Maybe String
olock1 Position
_   ) ==
    (CHSContext Maybe String
olib2 Maybe String
opref2 Maybe String
olock2 Position
_   ) =    
    Maybe String
olib1 forall a. Eq a => a -> a -> Bool
== Maybe String
olib1 Bool -> Bool -> Bool
&& Maybe String
opref1 forall a. Eq a => a -> a -> Bool
== Maybe String
opref2 Bool -> Bool -> Bool
&& Maybe String
olock1 forall a. Eq a => a -> a -> Bool
== Maybe String
olock2
  (CHSType Ident
ide1                Position
_) == (CHSType Ident
ide2                Position
_) = 
    Ident
ide1 forall a. Eq a => a -> a -> Bool
== Ident
ide2
  (CHSSizeof Ident
ide1              Position
_) == (CHSSizeof Ident
ide2              Position
_) = 
    Ident
ide1 forall a. Eq a => a -> a -> Bool
== Ident
ide2
  (CHSEnum Ident
ide1 Maybe Ident
oalias1 CHSTrans
_ Maybe String
_ [Ident]
_  Position
_) == (CHSEnum Ident
ide2 Maybe Ident
oalias2 CHSTrans
_ Maybe String
_ [Ident]
_  Position
_) = 
    Maybe Ident
oalias1 forall a. Eq a => a -> a -> Bool
== Maybe Ident
oalias2 Bool -> Bool -> Bool
&& Ident
ide1 forall a. Eq a => a -> a -> Bool
== Ident
ide2
  (CHSCall Bool
_ Bool
_ Bool
_ Ident
ide1 Maybe Ident
oalias1    Position
_) == (CHSCall Bool
_ Bool
_ Bool
_ Ident
ide2 Maybe Ident
oalias2    Position
_) = 
    Maybe Ident
oalias1 forall a. Eq a => a -> a -> Bool
== Maybe Ident
oalias2 Bool -> Bool -> Bool
&& Ident
ide1 forall a. Eq a => a -> a -> Bool
== Ident
ide2
  (CHSFun  Bool
_ Bool
_ Bool
_ Ident
ide1 Maybe Ident
oalias1 Maybe String
_ [CHSParm]
_ CHSParm
_ Position
_) 
                                  == (CHSFun Bool
_ Bool
_ Bool
_ Ident
ide2 Maybe Ident
oalias2 Maybe String
_ [CHSParm]
_ CHSParm
_ Position
_) = 
    Maybe Ident
oalias1 forall a. Eq a => a -> a -> Bool
== Maybe Ident
oalias2 Bool -> Bool -> Bool
&& Ident
ide1 forall a. Eq a => a -> a -> Bool
== Ident
ide2
  (CHSField CHSAccess
acc1 CHSAPath
path1         Position
_) == (CHSField CHSAccess
acc2 CHSAPath
path2         Position
_) =    
    CHSAccess
acc1 forall a. Eq a => a -> a -> Bool
== CHSAccess
acc2 Bool -> Bool -> Bool
&& CHSAPath
path1 forall a. Eq a => a -> a -> Bool
== CHSAPath
path2
  (CHSPointer Bool
_ Ident
ide1 Maybe Ident
oalias1 CHSPtrType
_ Bool
_ Maybe Ident
_ Position
_) 
                                  == (CHSPointer Bool
_ Ident
ide2 Maybe Ident
oalias2 CHSPtrType
_ Bool
_ Maybe Ident
_ Position
_) =
    Ident
ide1 forall a. Eq a => a -> a -> Bool
== Ident
ide2 Bool -> Bool -> Bool
&& Maybe Ident
oalias1 forall a. Eq a => a -> a -> Bool
== Maybe Ident
oalias2
  (CHSClass Maybe Ident
_ Ident
ide1 Ident
_           Position
_) == (CHSClass Maybe Ident
_ Ident
ide2 Ident
_           Position
_) =
    Ident
ide1 forall a. Eq a => a -> a -> Bool
== Ident
ide2
  CHSHook
_                               == CHSHook
_                          = Bool
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 (CHSArg -> CHSArg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHSArg -> CHSArg -> Bool
$c/= :: CHSArg -> CHSArg -> Bool
== :: CHSArg -> CHSArg -> Bool
$c== :: CHSArg -> CHSArg -> Bool
Eq)

-- structure member access types (EXPORTED)
--
data CHSAccess = CHSSet                         -- set structure field
               | CHSGet                         -- get structure field
               deriving (CHSAccess -> CHSAccess -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHSAccess -> CHSAccess -> Bool
$c/= :: CHSAccess -> CHSAccess -> Bool
== :: CHSAccess -> CHSAccess -> Bool
$c== :: CHSAccess -> CHSAccess -> Bool
Eq)

-- structure access path (EXPORTED)
--
data CHSAPath = CHSRoot  Ident                  -- root of access path
              | CHSDeref CHSAPath Position      -- dereferencing
              | CHSRef   CHSAPath Ident         -- member referencing
              deriving (CHSAPath -> CHSAPath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHSAPath -> CHSAPath -> Bool
$c/= :: CHSAPath -> CHSAPath -> Bool
== :: CHSAPath -> CHSAPath -> Bool
$c== :: CHSAPath -> CHSAPath -> Bool
Eq)

-- pointer options (EXPORTED)
--

data CHSPtrType = CHSPtr                        -- standard Ptr from Haskell
                | CHSForeignPtr                 -- a pointer with a finalizer
                | CHSStablePtr                  -- a pointer into Haskell land
                deriving (CHSPtrType -> CHSPtrType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHSPtrType -> CHSPtrType -> Bool
$c/= :: CHSPtrType -> CHSPtrType -> Bool
== :: CHSPtrType -> CHSPtrType -> Bool
$c== :: CHSPtrType -> CHSPtrType -> Bool
Eq)

instance Show CHSPtrType where
  show :: CHSPtrType -> String
show CHSPtrType
CHSPtr            = String
"Ptr"
  show CHSPtrType
CHSForeignPtr     = String
"ForeignPtr"
  show CHSPtrType
CHSStablePtr      = String
"StablePtr"

instance Read CHSPtrType where
  readsPrec :: Int -> ReadS CHSPtrType
readsPrec Int
_ (                            Char
'P':Char
't':Char
'r':String
rest) = 
    [(CHSPtrType
CHSPtr, String
rest)]
  readsPrec Int
_ (Char
'F':Char
'o':Char
'r':Char
'e':Char
'i':Char
'g':Char
'n':Char
'P':Char
't':Char
'r':String
rest) = 
    [(CHSPtrType
CHSForeignPtr, String
rest)]
  readsPrec Int
_ (Char
'S':Char
't':Char
'a':Char
'b':Char
'l':Char
'e'    :Char
'P':Char
't':Char
'r':String
rest) = 
    [(CHSPtrType
CHSStablePtr, String
rest)]
  readsPrec Int
p (Char
c:String
cs)
    | Char -> Bool
isSpace Char
c                                              = forall a. Read a => Int -> ReadS a
readsPrec Int
p String
cs
  readsPrec Int
_ String
_                                              = []


-- 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 -> Maybe CHSModule
skipToLangPragma (CHSModule [CHSFrag]
frags) = [CHSFrag] -> Maybe CHSModule
hLP [CHSFrag]
frags
  where
  hLP :: [CHSFrag] -> Maybe CHSModule
hLP all :: [CHSFrag]
all@(CHSLang [String]
exts Position
_:[CHSFrag]
_) = forall a. a -> Maybe a
Just ([CHSFrag] -> CHSModule
CHSModule [CHSFrag]
all)
  hLP (CHSFrag
x:[CHSFrag]
xs) = [CHSFrag] -> Maybe CHSModule
hLP [CHSFrag]
xs
  hLP [] = forall a. Maybe a
Nothing

-- test if the language pragma contains the CPP option
hasCPP :: CHSModule -> Bool
hasCPP :: CHSModule -> Bool
hasCPP (CHSModule (CHSLang [String]
exts Position
_:[CHSFrag]
_)) = String
"CPP" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
exts
hasCPP CHSModule
_ = Bool
False

-- load and dump a CHS file
-- ------------------------

hssuffix, chssuffix :: String
hssuffix :: String
hssuffix  = String
".hs"
chssuffix :: String
chssuffix = String
".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 :: forall s. String -> CST s (CHSModule, String)
loadCHS String
fname = do
   -- parse
   --
   forall {s}. String -> CST s ()
traceInfoRead String
fname
   String
contents <- forall e s. String -> PreCST e s String
readFileCIO String
fname 
   forall {s}. CST s ()
traceInfoParse
   CHSModule
mod <- forall s. Position -> String -> CST s CHSModule
parseCHSModule (String -> Int -> Int -> Position
Position String
fname Int
1 Int
1) String
contents

   -- check for errors and finalize
   --
   Bool
errs <- forall e s. PreCST e s Bool
errorsPresent
   if Bool
errs
     then do
       forall {s}. CST s ()
traceInfoErr
       String
errmsgs <- forall e s. PreCST e s String
showErrors
       forall e s a. String -> PreCST e s a
fatal (String
"CHS module contains \
              \errors:\n\n" forall a. [a] -> [a] -> [a]
++ String
errmsgs)   -- fatal error
     else do
       forall {s}. CST s ()
traceInfoOK
       String
warnmsgs <- forall e s. PreCST e s String
showErrors
       forall (m :: * -> *) a. Monad m => a -> m a
return (CHSModule
mod, String
warnmsgs)
  where
    traceInfoRead :: String -> CST s ()
traceInfoRead String
fname = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
                            (String
"Attempting to read file `"
                             forall a. [a] -> [a] -> [a]
++ String
fname forall a. [a] -> [a] -> [a]
++ String
"'...\n")
    traceInfoParse :: CST s ()
traceInfoParse      = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW 
                            (String
"...parsing `" 
                             forall a. [a] -> [a] -> [a]
++ String
fname forall a. [a] -> [a] -> [a]
++ String
"'...\n")
    traceInfoErr :: CST s ()
traceInfoErr        = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
                            (String
"...error(s) detected in `"
                             forall a. [a] -> [a] -> [a]
++ String
fname forall a. [a] -> [a] -> [a]
++ String
"'.\n")
    traceInfoOK :: CST s ()
traceInfoOK         = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
                            (String
"...successfully loaded `"
                             forall a. [a] -> [a] -> [a]
++ String
fname forall a. [a] -> [a] -> [a]
++ String
"'.\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 :: forall s. String -> CHSModule -> Bool -> CST s ()
dumpCHS String
fname CHSModule
mod Bool
pureHaskell  =
  do
    let (String
suffix, String
kind) = if Bool
pureHaskell
                         then (String
hssuffix , String
"(Haskell)")
                         else (String
chssuffix, String
"(C->HS binding)")
    (String
version, String
_, String
_) <- forall e s. PreCST e s (String, String, String)
getId
    forall e s. String -> String -> PreCST e s ()
writeFileCIO (String
fname forall a. [a] -> [a] -> [a]
++ String
suffix) (String -> ShowS
contents String
version String
kind)
  where
    contents :: String -> ShowS
contents String
version String
kind | CHSModule -> Bool
hasCPP CHSModule
mod = CHSModule -> Bool -> String
showCHSModule CHSModule
mod Bool
pureHaskell
                          | Bool
otherwise = 
      String
"-- GENERATED by " forall a. [a] -> [a] -> [a]
++ String
version forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
kind forall a. [a] -> [a] -> [a]
++ String
"\n\
      \-- Edit the ORIGNAL .chs file instead!\n\n"
      forall a. [a] -> [a] -> [a]
++ CHSModule -> Bool -> String
showCHSModule CHSModule
mod Bool
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 (LineState -> LineState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineState -> LineState -> Bool
$c/= :: LineState -> LineState -> Bool
== :: LineState -> LineState -> Bool
$c== :: LineState -> LineState -> Bool
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 -> Bool -> String
showCHSModule (CHSModule [CHSFrag]
frags) Bool
pureHaskell  = 
  Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHaskell LineState
Emit [CHSFrag]
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 :: Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
_      LineState
_     []                           = forall a. a -> a
id
    showFrags Bool
pureHs LineState
state (CHSVerb String
s      Position
pos : [CHSFrag]
frags) = 
      let
        (Position String
fname Int
line Int
_) = Position
pos
        generated :: Bool
generated        = Position -> Bool
isBuiltinPos Position
pos
        emitNow :: Bool
emitNow          = LineState
state forall a. Eq a => a -> a -> Bool
== LineState
Emit Bool -> Bool -> Bool
|| 
                           (LineState
state forall a. Eq a => a -> a -> Bool
== LineState
Wait Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) Bool -> Bool -> Bool
&& Bool
nlStart)
        nlStart :: Bool
nlStart          = forall a. [a] -> a
head String
s forall a. Eq a => a -> a -> Bool
== Char
'\n'
        nextState :: LineState
nextState        = if Bool
generated then LineState
Wait else LineState
NoLine
      in
        (if Bool
emitNow then
           String -> ShowS
showString (String
"\n{-# LINE " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
line forall a. Ord a => a -> a -> a
`max` Int
0) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ 
                       forall a. Show a => a -> String
show String
fname forall a. [a] -> [a] -> [a]
++ String
" #-}" forall a. [a] -> [a] -> [a]
++
                       (if Bool
nlStart then String
"" else String
"\n"))
         else forall a. a -> a
id)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHs LineState
nextState [CHSFrag]
frags
    showFrags Bool
False  LineState
_     (CHSHook CHSHook
hook       : [CHSFrag]
frags) =   
        String -> ShowS
showString String
"{#" 
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSHook -> ShowS
showCHSHook CHSHook
hook
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"#}"
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
False LineState
Wait [CHSFrag]
frags
    showFrags Bool
False  LineState
_     (CHSCPP  String
s    Position
_     : [CHSFrag]
frags) =   
        Char -> ShowS
showChar Char
'#'
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s
--      . showChar '\n'
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
False LineState
Emit [CHSFrag]
frags
    showFrags Bool
pureHs LineState
_     (CHSLine Position
s          : [CHSFrag]
frags) =
        Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHs LineState
Emit [CHSFrag]
frags
    showFrags Bool
False  LineState
_     (CHSC    String
s    Position
_     : [CHSFrag]
frags) =
        String -> ShowS
showString String
"\n#c"
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"\n#endc"
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
False LineState
Emit [CHSFrag]
frags
    showFrags Bool
False  LineState
_     (CHSCond [(Ident, [CHSFrag])]
_    Maybe [CHSFrag]
_     : [CHSFrag]
frags) =
      forall a. String -> a
interr String
"showCHSFrag: Cannot print `CHSCond'!"
    showFrags Bool
pureHs LineState
_     (CHSLang [String]
exts Position
_     : [CHSFrag]
frags) =
      let extsNoCPP :: [String]
extsNoCPP = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
(/=) String
"CPP") [String]
exts in
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extsNoCPP then Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHs LineState
Emit [CHSFrag]
frags else
        String -> ShowS
showString String
"{-# LANGUAGE "
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
"," [String]
extsNoCPP))
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" #-}\n"
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> LineState -> [CHSFrag] -> ShowS
showFrags Bool
pureHs LineState
Emit [CHSFrag]
frags
    showFrags Bool
True   LineState
_     [CHSFrag]
_                            =
      forall a. String -> a
interr String
"showCHSFrag: Illegal hook, cpp directive, or inline C code!"

showCHSHook :: CHSHook -> ShowS
showCHSHook :: CHSHook -> ShowS
showCHSHook (CHSImport Bool
isQual Ident
ide String
_ Position
_) =   
    String -> ShowS
showString String
"import "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isQual then String -> ShowS
showString String
"qualified " else forall a. a -> a
id)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSHook (CHSContext Maybe String
olib Maybe String
oprefix Maybe String
olock Position
_) =   
    String -> ShowS
showString String
"context "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe String
olib of
       Maybe String
Nothing  -> String -> ShowS
showString String
""
       Just String
lib -> String -> ShowS
showString String
"lib = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
lib forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Bool -> ShowS
showPrefix Maybe String
oprefix Bool
False
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe String
olock of
       Maybe String
Nothing  -> String -> ShowS
showString String
""
       Just String
lock -> String -> ShowS
showString String
"lock = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
lock forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" ")
showCHSHook (CHSType Ident
ide Position
_) =   
    String -> ShowS
showString String
"type "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSHook (CHSSizeof Ident
ide Position
_) =   
    String -> ShowS
showString String
"sizeof "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSHook (CHSEnum Ident
ide Maybe Ident
oalias CHSTrans
trans Maybe String
oprefix [Ident]
derive Position
_) =   
    String -> ShowS
showString String
"enum "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSTrans -> ShowS
showCHSTrans CHSTrans
trans
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> Bool -> ShowS
showPrefix Maybe String
oprefix Bool
True
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
derive then forall a. a -> a
id else String -> ShowS
showString forall a b. (a -> b) -> a -> b
$
      String
"deriving (" 
      forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
", " (forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
identToLexeme [Ident]
derive))
      forall a. [a] -> [a] -> [a]
++ String
") "
showCHSHook (CHSCall Bool
isPure Bool
isUns Bool
isNol Ident
ide Maybe Ident
oalias Position
_) =   
    String -> ShowS
showString String
"call "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isPure then String -> ShowS
showString String
"pure " else forall a. a -> a
id)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isUns then String -> ShowS
showString String
"unsafe " else forall a. a -> a
id)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isNol then String -> ShowS
showString String
"nolock " else forall a. a -> a
id)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias
showCHSHook (CHSFun Bool
isPure Bool
isUns Bool
isNol Ident
ide Maybe Ident
oalias Maybe String
octxt [CHSParm]
parms CHSParm
parm Position
_) =   
    String -> ShowS
showString String
"fun "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isPure then String -> ShowS
showString String
"pure " else forall a. a -> a
id)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isUns then String -> ShowS
showString String
"unsafe " else forall a. a -> a
id)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
isNol then String -> ShowS
showString String
"nolock " else forall a. a -> a
id)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe String
octxt of
       Maybe String
Nothing      -> Char -> ShowS
showChar Char
' '
       Just String
ctxtStr -> String -> ShowS
showString String
ctxtStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" => ")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"{"
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a. a -> [a] -> [a]
intersperse (String -> ShowS
showString String
", ") (forall a b. (a -> b) -> [a] -> [b]
map CHSParm -> ShowS
showCHSParm [CHSParm]
parms))
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"} -> "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSParm -> ShowS
showCHSParm CHSParm
parm
showCHSHook (CHSField CHSAccess
acc CHSAPath
path Position
_) =   
    (case CHSAccess
acc of
       CHSAccess
CHSGet -> String -> ShowS
showString String
"get "
       CHSAccess
CHSSet -> String -> ShowS
showString String
"set ")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSAPath -> ShowS
showCHSAPath CHSAPath
path
showCHSHook (CHSPointer Bool
star Ident
ide Maybe Ident
oalias CHSPtrType
ptrType Bool
isNewtype Maybe Ident
oRefType Position
_) =
    String -> ShowS
showString String
"pointer "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
star then String -> ShowS
showString String
"*" else String -> ShowS
showString String
"")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case CHSPtrType
ptrType of
       CHSPtrType
CHSForeignPtr -> String -> ShowS
showString String
" foreign"
       CHSPtrType
CHSStablePtr  -> String -> ShowS
showString String
" stable"
       CHSPtrType
_             -> String -> ShowS
showString String
"")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case (Bool
isNewtype, Maybe Ident
oRefType) of
       (Bool
True , Maybe Ident
_       ) -> String -> ShowS
showString String
" newtype" 
       (Bool
False, Just Ident
ide) -> String -> ShowS
showString String
" -> " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
       (Bool
False, Maybe Ident
Nothing ) -> String -> ShowS
showString String
"")
showCHSHook (CHSClass Maybe Ident
oclassIde Ident
classIde Ident
typeIde Position
_) =   
    String -> ShowS
showString String
"class "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe Ident
oclassIde of
       Maybe Ident
Nothing       -> String -> ShowS
showString String
""
       Just Ident
classIde -> Ident -> ShowS
showCHSIdent Ident
classIde forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" => ")
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
classIde
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
typeIde

showPrefix                        :: Maybe String -> Bool -> ShowS
showPrefix :: Maybe String -> Bool -> ShowS
showPrefix Maybe String
Nothing       Bool
_         = String -> ShowS
showString String
""
showPrefix (Just String
prefix) Bool
withWith  =   ShowS
maybeWith 
                                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"prefix = " 
                                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
prefix 
                                     forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
  where
    maybeWith :: ShowS
maybeWith = if Bool
withWith then String -> ShowS
showString String
"with " else forall a. a -> a
id

showIdAlias            :: Ident -> Maybe Ident -> ShowS
showIdAlias :: Ident -> Maybe Ident -> ShowS
showIdAlias Ident
ide Maybe Ident
oalias  =
    Ident -> ShowS
showCHSIdent Ident
ide
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case Maybe Ident
oalias of
       Maybe Ident
Nothing  -> forall a. a -> a
id
       Just Ident
ide -> String -> ShowS
showString String
" as " forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide)

showCHSParm                                                :: CHSParm -> ShowS
showCHSParm :: CHSParm -> ShowS
showCHSParm (CHSParm Maybe (Ident, CHSArg)
oimMarsh String
hsTyStr Bool
twoCVals Maybe (Ident, CHSArg)
oomMarsh Position
_)  =
    Maybe (Ident, CHSArg) -> ShowS
showOMarsh Maybe (Ident, CHSArg)
oimMarsh
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showHsVerb String
hsTyStr
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
twoCVals then Char -> ShowS
showChar Char
'&' else forall a. a -> a
id)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Ident, CHSArg) -> ShowS
showOMarsh Maybe (Ident, CHSArg)
oomMarsh
  where
    showOMarsh :: Maybe (Ident, CHSArg) -> ShowS
showOMarsh Maybe (Ident, CHSArg)
Nothing               = forall a. a -> a
id
    showOMarsh (Just (Ident
ide, CHSArg
argKind)) =   Ident -> ShowS
showCHSIdent Ident
ide
                                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case CHSArg
argKind of
                                           CHSArg
CHSValArg  -> forall a. a -> a
id
                                           CHSArg
CHSIOArg   -> String -> ShowS
showString String
"*"
                                           CHSArg
CHSVoidArg -> String -> ShowS
showString String
"-")
    --
    showHsVerb :: String -> ShowS
showHsVerb String
str = Char -> ShowS
showChar Char
'`' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
str forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\''

showCHSTrans                          :: CHSTrans -> ShowS
showCHSTrans :: CHSTrans -> ShowS
showCHSTrans (CHSTrans Bool
_2Case [(Ident, Ident)]
assocs)  =   
    String -> ShowS
showString String
"{"
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
_2Case then String -> ShowS
showString (String
"underscoreToCase" forall a. [a] -> [a] -> [a]
++ String
maybeComma) else forall a. a -> a
id)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a. a -> [a] -> [a]
intersperse (String -> ShowS
showString String
", ") (forall a b. (a -> b) -> [a] -> [b]
map (Ident, Ident) -> ShowS
showAssoc [(Ident, Ident)]
assocs))
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"}"
  where
    maybeComma :: String
maybeComma = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, Ident)]
assocs then String
"" else String
", "
    --
    showAssoc :: (Ident, Ident) -> ShowS
showAssoc (Ident
ide1, Ident
ide2) =
        Ident -> ShowS
showCHSIdent Ident
ide1
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" as "
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide2

showCHSAPath :: CHSAPath -> ShowS
showCHSAPath :: CHSAPath -> ShowS
showCHSAPath (CHSRoot Ident
ide) =
  Ident -> ShowS
showCHSIdent Ident
ide
showCHSAPath (CHSDeref CHSAPath
path Position
_) =
    String -> ShowS
showString String
"* "
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSAPath -> ShowS
showCHSAPath CHSAPath
path
showCHSAPath (CHSRef (CHSDeref CHSAPath
path Position
_) Ident
ide) =
    CHSAPath -> ShowS
showCHSAPath CHSAPath
path
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"->"
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide
showCHSAPath (CHSRef CHSAPath
path Ident
ide) =
   CHSAPath -> ShowS
showCHSAPath CHSAPath
path
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"."
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ShowS
showCHSIdent Ident
ide

showCHSIdent :: Ident -> ShowS
showCHSIdent :: Ident -> ShowS
showCHSIdent  = String -> ShowS
showString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> String
identToLexeme


-- load and dump a CHI file
-- ------------------------

chisuffix :: String
chisuffix :: String
chisuffix  = String
".chi"

versionPrefix :: String
versionPrefix :: String
versionPrefix  = String
"C->Haskell Interface Version "

-- replace all import names with the content of the CHI file
loadAllCHI :: CHSModule -> CST s CHSModule
loadAllCHI :: forall s. CHSModule -> CST s CHSModule
loadAllCHI (CHSModule [CHSFrag]
frags) = do
        let checkFrag :: CHSFrag -> PreCST SwitchBoard s CHSFrag
checkFrag (CHSHook (CHSImport Bool
qual Ident
name String
fName Position
pos)) = do
                String
chi <- forall s. String -> CST s String
loadCHI String
fName
                forall (m :: * -> *) a. Monad m => a -> m a
return (CHSHook -> CHSFrag
CHSHook (Bool -> Ident -> String -> Position -> CHSHook
CHSImport Bool
qual Ident
name String
chi Position
pos))
            checkFrag CHSFrag
h = forall (m :: * -> *) a. Monad m => a -> m a
return CHSFrag
h
        [CHSFrag]
frags' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {s}. CHSFrag -> PreCST SwitchBoard s CHSFrag
checkFrag [CHSFrag]
frags
        forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CHSModule
CHSModule [CHSFrag]
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 :: forall s. String -> CST s String
loadCHI String
fname  = do
                   -- search for .chi files
                   --
                   [String]
paths <- forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> [String]
chiPathSB
                   let fullnames :: [String]
fullnames = [String
path forall a. [a] -> [a] -> [a]
++ Char
'/'forall a. a -> [a] -> [a]
:String
fname forall a. [a] -> [a] -> [a]
++ String
chisuffix | 
                                    String
path <- [String]
paths]
                   String
fullname <- forall {e} {s}. [String] -> PreCST e s String -> PreCST e s String
findFirst [String]
fullnames
                     (forall e s a. String -> PreCST e s a
fatal forall a b. (a -> b) -> a -> b
$ String
fnameforall a. [a] -> [a] -> [a]
++String
chisuffixforall a. [a] -> [a] -> [a]
++String
" not found in:\n"forall a. [a] -> [a] -> [a]
++
                              [String] -> String
unlines [String]
paths)
                   -- read file
                   --
                   forall {s}. String -> CST s ()
traceInfoRead String
fullname
                   String
contents <- forall e s. String -> PreCST e s String
readFileCIO String
fullname

                   -- parse
                   --
                   forall {s}. CST s ()
traceInfoVersion
                   let ls :: [String]
ls = String -> [String]
lines String
contents
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ls) forall a b. (a -> b) -> a -> b
$
                     forall s a. String -> CST s a
errorCHICorrupt String
fname
                   let String
versline:[String]
chi = [String]
ls
                       prefixLen :: Int
prefixLen    = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
versionPrefix
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
versline forall a. Ord a => a -> a -> Bool
< Int
prefixLen
                         Bool -> Bool -> Bool
|| forall a. Int -> [a] -> [a]
take Int
prefixLen String
versline forall a. Eq a => a -> a -> Bool
/= String
versionPrefix) forall a b. (a -> b) -> a -> b
$
                     forall s a. String -> CST s a
errorCHICorrupt String
fname
                   let versline' :: String
versline' = forall a. Int -> [a] -> [a]
drop Int
prefixLen String
versline
                   (String
major, String
minor) <- case String -> Maybe (String, String)
majorMinor String
versline' of
                                       Maybe (String, String)
Nothing     -> forall s a. String -> CST s a
errorCHICorrupt String
fname
                                       Just (String, String)
majMin -> forall (m :: * -> *) a. Monad m => a -> m a
return (String, String)
majMin
                     
                   (String
version, String
_, String
_) <- forall e s. PreCST e s (String, String, String)
getId
                   let Just (String
myMajor, String
myMinor) = String -> Maybe (String, String)
majorMinor String
version
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
major forall a. Eq a => a -> a -> Bool
/= String
myMajor Bool -> Bool -> Bool
|| String
minor forall a. Eq a => a -> a -> Bool
/= String
myMinor) forall a b. (a -> b) -> a -> b
$
                     forall s a. String -> String -> String -> CST s a
errorCHIVersion String
fname 
                       (String
major forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
minor) (String
myMajor forall a. [a] -> [a] -> [a]
++ String
"." forall a. [a] -> [a] -> [a]
++ String
myMinor)

                   -- finalize
                   --
                   forall {s}. CST s ()
traceInfoOK
                   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
chi
                  where
                    traceInfoRead :: String -> CST s ()
traceInfoRead String
fname = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
                                            (String
"Attempting to read file `"
                                             forall a. [a] -> [a] -> [a]
++ String
fname forall a. [a] -> [a] -> [a]
++ String
"'...\n")
                    traceInfoVersion :: CST s ()
traceInfoVersion    = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW 
                                            (String
"...checking version `" 
                                             forall a. [a] -> [a] -> [a]
++ String
fname forall a. [a] -> [a] -> [a]
++ String
"'...\n")
                    traceInfoOK :: CST s ()
traceInfoOK         = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
                                            (String
"...successfully loaded `"
                                             forall a. [a] -> [a] -> [a]
++ String
fname forall a. [a] -> [a] -> [a]
++ String
"'.\n")
                    findFirst :: [String] -> PreCST e s String -> PreCST e s String
findFirst []        PreCST e s String
err =  PreCST e s String
err
                    findFirst (String
p:[String]
aths)  PreCST e s String
err =  do
                      Bool
e <- forall e s. String -> PreCST e s Bool
doesFileExistCIO String
p
                      if Bool
e then forall (m :: * -> *) a. Monad m => a -> m a
return String
p else [String] -> PreCST e s String -> PreCST e s String
findFirst [String]
aths PreCST e s String
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 :: forall s. String -> String -> CST s ()
dumpCHI String
fname String
contents  =
  do
    (String
version, String
_, String
_) <- forall e s. PreCST e s (String, String, String)
getId
    forall e s. String -> String -> PreCST e s ()
writeFileCIO (String
fname forall a. [a] -> [a] -> [a]
++ String
chisuffix) forall a b. (a -> b) -> a -> b
$
      String
versionPrefix forall a. [a] -> [a] -> [a]
++ String
version forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ String
contents

-- extract major and minor number from a version string
--
majorMinor      :: String -> Maybe (String, String)
majorMinor :: String -> Maybe (String, String)
majorMinor String
vers  = let (String
major, String
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'.') String
vers
                       (String
minor, String
_   ) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'.') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ String
rest
                   in
                   if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (String
major, String
minor)


-- parsing a CHS token stream
-- --------------------------

syntaxExc :: String
syntaxExc :: String
syntaxExc  = String
"syntax"

-- alternative action in case of a syntax exception
--
ifError                :: CST s a -> CST s a -> CST s a
ifError :: forall s a. CST s a -> CST s a -> CST s a
ifError CST s a
action CST s a
handler  = CST s a
action forall e s a.
PreCST e s a -> (String, String -> PreCST e s a) -> PreCST e s a
`catchExc` (String
syntaxExc, forall a b. a -> b -> a
const CST s a
handler)

-- raise syntax error exception
--
raiseSyntaxError :: CST s a
raiseSyntaxError :: forall s a. CST s a
raiseSyntaxError  = forall e s a. String -> String -> PreCST e s a
throwExc String
syntaxExc String
"syntax error"

-- parse a complete module
--
--  * errors are entered into the compiler state
--
parseCHSModule        :: Position -> String -> CST s CHSModule
parseCHSModule :: forall s. Position -> String -> CST s CHSModule
parseCHSModule Position
pos String
cs  = do
                           [CHSToken]
toks <- forall s. String -> Position -> CST s [CHSToken]
lexCHS String
cs Position
pos
                           [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
                           forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CHSModule
CHSModule [CHSFrag]
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 :: forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks  = do
                     forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags0 [CHSToken]
toks
                     forall s a. CST s a -> CST s a -> CST s a
`ifError` forall s. [CHSToken] -> CST s [CHSFrag]
contFrags [CHSToken]
toks
  where
    parseFrags0 :: [CHSToken] -> CST s [CHSFrag]
    parseFrags0 :: forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags0 []                         = forall (m :: * -> *) a. Monad m => a -> m a
return []
    parseFrags0 (CHSTokHaskell Position
pos String
s:[CHSToken]
toks) = do
                                               [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
                                               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSVerb String
s Position
pos forall a. a -> [a] -> [a]
: [CHSFrag]
frags
    parseFrags0 (CHSTokCtrl    Position
pos Char
c:[CHSToken]
toks) = do
                                               [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
                                               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSVerb [Char
c] Position
pos forall a. a -> [a] -> [a]
: [CHSFrag]
frags
    parseFrags0 (CHSTokCPP     Position
pos String
s:[CHSToken]
toks) = do
                                               [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
                                               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSCPP String
s Position
pos forall a. a -> [a] -> [a]
: [CHSFrag]
frags
    parseFrags0 (CHSTokLine    Position
pos  :[CHSToken]
toks) = do
                                               [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
                                               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Position -> CHSFrag
CHSLine Position
pos forall a. a -> [a] -> [a]
: [CHSFrag]
frags
    parseFrags0 (CHSTokC       Position
pos String
s:[CHSToken]
toks) = forall s. Position -> String -> [CHSToken] -> CST s [CHSFrag]
parseC       Position
pos String
s      [CHSToken]
toks 
    parseFrags0 (CHSTokImport  Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseImport  Position
pos        [CHSToken]
toks
    parseFrags0 (CHSTokContext Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseContext Position
pos        [CHSToken]
toks
    parseFrags0 (CHSTokType    Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseType    Position
pos        [CHSToken]
toks
    parseFrags0 (CHSTokSizeof  Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseSizeof  Position
pos        [CHSToken]
toks
    parseFrags0 (CHSTokEnum    Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseEnum    Position
pos        [CHSToken]
toks
    parseFrags0 (CHSTokCall    Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseCall    Position
pos        [CHSToken]
toks
    parseFrags0 (CHSTokFun     Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseFun     Position
pos        [CHSToken]
toks
    parseFrags0 (CHSTokGet     Position
pos  :[CHSToken]
toks) = forall s. Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField   Position
pos CHSAccess
CHSGet [CHSToken]
toks
    parseFrags0 (CHSTokSet     Position
pos  :[CHSToken]
toks) = forall s. Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField   Position
pos CHSAccess
CHSSet [CHSToken]
toks
    parseFrags0 (CHSTokClass   Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseClass   Position
pos        [CHSToken]
toks
    parseFrags0 (CHSTokPointer Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parsePointer Position
pos        [CHSToken]
toks
    parseFrags0 (CHSTokPragma  Position
pos  :[CHSToken]
toks) = forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parsePragma  Position
pos        [CHSToken]
toks
    parseFrags0 [CHSToken]
toks                       = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
    --
    -- skip to next Haskell or control token
    --
    contFrags :: [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
contFrags      []                       = forall (m :: * -> *) a. Monad m => a -> m a
return []
    contFrags toks :: [CHSToken]
toks@(CHSTokHaskell Position
_ String
_:[CHSToken]
_   ) = forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
    contFrags toks :: [CHSToken]
toks@(CHSTokCtrl    Position
_ Char
_:[CHSToken]
_   ) = forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
    contFrags      (CHSToken
_                :[CHSToken]
toks) = [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
contFrags  [CHSToken]
toks

parseC :: Position -> String -> [CHSToken] -> CST s [CHSFrag]
parseC :: forall s. Position -> String -> [CHSToken] -> CST s [CHSFrag]
parseC Position
pos String
s [CHSToken]
toks = 
  do
    [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
collectCtrlAndC [CHSToken]
toks
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSC String
s Position
pos forall a. a -> [a] -> [a]
: [CHSFrag]
frags
  where
    collectCtrlAndC :: [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
collectCtrlAndC (CHSTokCtrl Position
pos Char
c:[CHSToken]
toks) = do
                                                [CHSFrag]
frags <- [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
collectCtrlAndC [CHSToken]
toks
                                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSC [Char
c] Position
pos forall a. a -> [a] -> [a]
: [CHSFrag]
frags
    collectCtrlAndC (CHSTokC    Position
pos String
s:[CHSToken]
toks) = do
                                                [CHSFrag]
frags <- [CHSToken] -> PreCST SwitchBoard s [CHSFrag]
collectCtrlAndC [CHSToken]
toks
                                                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Position -> CHSFrag
CHSC String
s   Position
pos forall a. a -> [a] -> [a]
: [CHSFrag]
frags
    collectCtrlAndC [CHSToken]
toks                    = forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks

parseImport :: Position -> [CHSToken] -> CST s [CHSFrag]
parseImport :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseImport Position
pos [CHSToken]
toks = do
  (Bool
qual, Ident
modid, [CHSToken]
toks') <- 
    case [CHSToken]
toks of
      CHSTokIdent Position
_ Ident
ide                :[CHSToken]
toks ->
        let (Ident
ide', [CHSToken]
toks') = Ident -> [CHSToken] -> (Ident, [CHSToken])
rebuildModuleId Ident
ide [CHSToken]
toks
         in forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Ident
ide', [CHSToken]
toks')
      CHSTokQualif Position
_: CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks ->
        let (Ident
ide', [CHSToken]
toks') = Ident -> [CHSToken] -> (Ident, [CHSToken])
rebuildModuleId Ident
ide [CHSToken]
toks
         in forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , Ident
ide', [CHSToken]
toks')
      [CHSToken]
_                                      -> forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
  let fName :: String
fName = ShowS
moduleNameToFileName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> String
identToLexeme forall a b. (a -> b) -> a -> b
$ Ident
modid
  [CHSToken]
toks'' <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks'
  [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks''
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Bool -> Ident -> String -> Position -> CHSHook
CHSImport Bool
qual Ident
modid String
fName Position
pos) forall a. a -> [a] -> [a]
: [CHSFrag]
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 Ident
ide (CHSTokDot Position
_ : CHSTokIdent Position
_ Ident
ide' : [CHSToken]
toks) = 
  let catIdent :: Ident -> Ident -> Ident
catIdent Ident
ide Ident
ide' = Position -> String -> Ident
onlyPosIdent (forall a. Pos a => a -> Position
posOf Ident
ide)  --FIXME: unpleasent hack
                            (Ident -> String
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ Char
'.' forall a. a -> [a] -> [a]
: Ident -> String
identToLexeme Ident
ide')
   in Ident -> [CHSToken] -> (Ident, [CHSToken])
rebuildModuleId (Ident -> Ident -> Ident
catIdent Ident
ide Ident
ide') [CHSToken]
toks
rebuildModuleId Ident
ide                                     [CHSToken]
toks  = (Ident
ide, [CHSToken]
toks)

moduleNameToFileName :: String -> FilePath
moduleNameToFileName :: ShowS
moduleNameToFileName = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
dotToSlash
  where dotToSlash :: Char -> Char
dotToSlash Char
'.' = Char
'/'
        dotToSlash Char
c   = Char
c

parseContext          :: Position -> [CHSToken] -> CST s [CHSFrag]
parseContext :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseContext Position
pos [CHSToken]
toks  = do
                           (Maybe String
olib    , [CHSToken]
toks ) <- forall s. [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLib          [CHSToken]
toks
                           (Maybe String
opref   , [CHSToken]
toks)  <- forall s. Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix Bool
False [CHSToken]
toks
                           (Maybe String
olock   , [CHSToken]
toks)  <- forall s. [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLock         [CHSToken]
toks
                           [CHSToken]
toks              <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook         [CHSToken]
toks
                           [CHSFrag]
frags             <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags           [CHSToken]
toks
                           let frag :: CHSHook
frag = Maybe String -> Maybe String -> Maybe String -> Position -> CHSHook
CHSContext Maybe String
olib Maybe String
opref Maybe String
olock Position
pos
                           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook CHSHook
frag forall a. a -> [a] -> [a]
: [CHSFrag]
frags

parseType :: Position -> [CHSToken] -> CST s [CHSFrag]
parseType :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseType Position
pos (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
  do
    [CHSToken]
toks' <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
    [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Ident -> Position -> CHSHook
CHSType Ident
ide Position
pos) forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseType Position
_ [CHSToken]
toks = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks

parseSizeof :: Position -> [CHSToken] -> CST s [CHSFrag]
parseSizeof :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseSizeof Position
pos (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
  do
    [CHSToken]
toks' <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
    [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Ident -> Position -> CHSHook
CHSSizeof Ident
ide Position
pos) forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseSizeof Position
_ [CHSToken]
toks = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks

parseEnum :: Position -> [CHSToken] -> CST s [CHSFrag]
parseEnum :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseEnum Position
pos (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
  do
    (Maybe Ident
oalias, [CHSToken]
toks' )   <- forall s.
Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
ide Bool
True [CHSToken]
toks
    (CHSTrans
trans , [CHSToken]
toks'')   <- forall s. [CHSToken] -> CST s (CHSTrans, [CHSToken])
parseTrans          [CHSToken]
toks'
    (Maybe String
oprefix, [CHSToken]
toks''') <- forall s. Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix Bool
True [CHSToken]
toks''
    ([Ident]
derive, [CHSToken]
toks'''') <- forall s. [CHSToken] -> CST s ([Ident], [CHSToken])
parseDerive         [CHSToken]
toks'''
    [CHSToken]
toks'''''          <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook        [CHSToken]
toks''''
    [CHSFrag]
frags              <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags          [CHSToken]
toks'''''
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Ident
-> Maybe Ident
-> CHSTrans
-> Maybe String
-> [Ident]
-> Position
-> CHSHook
CHSEnum Ident
ide (Maybe Ident -> Maybe Ident
norm Maybe Ident
oalias) CHSTrans
trans Maybe String
oprefix [Ident]
derive Position
pos) forall a. a -> [a] -> [a]
: [CHSFrag]
frags
  where
    norm :: Maybe Ident -> Maybe Ident
norm Maybe Ident
Nothing                   = forall a. Maybe a
Nothing
    norm (Just Ident
ide') | Ident
ide forall a. Eq a => a -> a -> Bool
== Ident
ide' = forall a. Maybe a
Nothing
                     | Bool
otherwise   = forall a. a -> Maybe a
Just Ident
ide'
parseEnum Position
_ [CHSToken]
toks = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks

parseCall          :: Position -> [CHSToken] -> CST s [CHSFrag]
parseCall :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseCall Position
pos [CHSToken]
toks  = 
  do
    (Bool
isPure  , [CHSToken]
toks ) <- forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure          [CHSToken]
toks
    (Bool
isUnsafe, [CHSToken]
toks ) <- forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe        [CHSToken]
toks
    (Bool
isNolock, [CHSToken]
toks ) <- forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock        [CHSToken]
toks
    (Ident
ide     , [CHSToken]
toks ) <- forall s. [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent           [CHSToken]
toks
    (Maybe Ident
oalias  , [CHSToken]
toks ) <- forall s.
Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
ide Bool
False [CHSToken]
toks
    [CHSToken]
toks              <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook         [CHSToken]
toks
    [CHSFrag]
frags             <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags           [CHSToken]
toks
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 
      CHSHook -> CHSFrag
CHSHook (Bool -> Bool -> Bool -> Ident -> Maybe Ident -> Position -> CHSHook
CHSCall Bool
isPure Bool
isUnsafe Bool
isNolock Ident
ide (Ident -> Maybe Ident -> Maybe Ident
norm Ident
ide Maybe Ident
oalias) Position
pos) forall a. a -> [a] -> [a]
: [CHSFrag]
frags

parseFun          :: Position -> [CHSToken] -> CST s [CHSFrag]
parseFun :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseFun Position
pos [CHSToken]
toks  = 
  do
    (Bool
isPure  , [CHSToken]
toks' ) <- forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure          [CHSToken]
toks
    (Bool
isUnsafe, [CHSToken]
toks'2) <- forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe        [CHSToken]
toks'
    (Bool
isNolock, [CHSToken]
toks'3) <- forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock        [CHSToken]
toks'2
    (Ident
ide     , [CHSToken]
toks'4) <- forall s. [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent           [CHSToken]
toks'3
    (Maybe Ident
oalias  , [CHSToken]
toks'5) <- forall s.
Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
ide Bool
False [CHSToken]
toks'4
    (Maybe String
octxt   , [CHSToken]
toks'6) <- forall {m :: * -> *}.
Monad m =>
[CHSToken] -> m (Maybe String, [CHSToken])
parseOptContext      [CHSToken]
toks'5
    ([CHSParm]
parms   , [CHSToken]
toks'7) <- forall {s}.
[CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms           [CHSToken]
toks'6
    (CHSParm
parm    , [CHSToken]
toks'8) <- forall s. [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm            [CHSToken]
toks'7
    [CHSToken]
toks'9             <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook         [CHSToken]
toks'8
    [CHSFrag]
frags              <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags           [CHSToken]
toks'9
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 
      CHSHook -> CHSFrag
CHSHook 
        (Bool
-> Bool
-> Bool
-> Ident
-> Maybe Ident
-> Maybe String
-> [CHSParm]
-> CHSParm
-> Position
-> CHSHook
CHSFun Bool
isPure Bool
isUnsafe Bool
isNolock Ident
ide (Ident -> Maybe Ident -> Maybe Ident
norm Ident
ide Maybe Ident
oalias) Maybe String
octxt [CHSParm]
parms CHSParm
parm Position
pos) forall a. a -> [a] -> [a]
:
      [CHSFrag]
frags
  where
    parseOptContext :: [CHSToken] -> m (Maybe String, [CHSToken])
parseOptContext (CHSTokHSVerb Position
_ String
ctxt:CHSTokDArrow Position
_:[CHSToken]
toks) =
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just String
ctxt, [CHSToken]
toks)
    parseOptContext [CHSToken]
toks                                      =
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing  , [CHSToken]
toks)
    --
    parseParms :: [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms (CHSTokLBrace Position
_:CHSTokRBrace Position
_:CHSTokArrow Position
_:[CHSToken]
toks) = 
      forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
    parseParms (CHSTokLBrace Position
_                             :[CHSToken]
toks) = 
      forall {s}.
[CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms' (Position -> CHSToken
CHSTokComma Position
noposforall a. a -> [a] -> [a]
:[CHSToken]
toks)
    parseParms                                              [CHSToken]
toks  = 
      forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
    --
    parseParms' :: [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms' (CHSTokRBrace Position
_:CHSTokArrow Position
_:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
    parseParms' (CHSTokComma Position
_               :[CHSToken]
toks) = do
      (CHSParm
parm , [CHSToken]
toks' ) <- forall s. [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm   [CHSToken]
toks
      ([CHSParm]
parms, [CHSToken]
toks'') <- [CHSToken] -> PreCST SwitchBoard s ([CHSParm], [CHSToken])
parseParms' [CHSToken]
toks'
      forall (m :: * -> *) a. Monad m => a -> m a
return (CHSParm
parmforall a. a -> [a] -> [a]
:[CHSParm]
parms, [CHSToken]
toks'')
    parseParms' (CHSTokRBrace Position
_              :[CHSToken]
toks) = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
      -- gives better error messages
    parseParms'                               [CHSToken]
toks  = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks

parseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure :: forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsPure (CHSTokPure Position
_:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsPure (CHSTokFun  Position
_:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)  -- backwards compat.
parseIsPure [CHSToken]
toks                = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [CHSToken]
toks)
-- FIXME: eventually, remove `fun'; it's currently deprecated

parseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe :: forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsUnsafe (CHSTokUnsafe Position
_:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsUnsafe [CHSToken]
toks                  = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [CHSToken]
toks)

parseIsNolock :: [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock :: forall s. [CHSToken] -> CST s (Bool, [CHSToken])
parseIsNolock (CHSTokNolock Position
_:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , [CHSToken]
toks)
parseIsNolock [CHSToken]
toks                  = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [CHSToken]
toks)

norm :: Ident -> Maybe Ident -> Maybe Ident
norm :: Ident -> Maybe Ident -> Maybe Ident
norm Ident
ide Maybe Ident
Nothing                   = forall a. Maybe a
Nothing
norm Ident
ide (Just Ident
ide') | Ident
ide forall a. Eq a => a -> a -> Bool
== Ident
ide' = forall a. Maybe a
Nothing
                     | Bool
otherwise   = forall a. a -> Maybe a
Just Ident
ide'

parseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm :: forall s. [CHSToken] -> CST s (CHSParm, [CHSToken])
parseParm [CHSToken]
toks =
  do
    (Maybe (Ident, CHSArg)
oimMarsh, [CHSToken]
toks' ) <- forall s. [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
parseOptMarsh [CHSToken]
toks
    (String
hsTyStr, Bool
twoCVals, Position
pos, [CHSToken]
toks'2) <- 
      case [CHSToken]
toks' of
        (CHSTokHSVerb Position
pos String
hsTyStr:CHSTokAmp Position
_:[CHSToken]
toks'2) -> 
          forall (m :: * -> *) a. Monad m => a -> m a
return (String
hsTyStr, Bool
True , Position
pos, [CHSToken]
toks'2)
        (CHSTokHSVerb Position
pos String
hsTyStr            :[CHSToken]
toks'2) -> 
          forall (m :: * -> *) a. Monad m => a -> m a
return (String
hsTyStr, Bool
False, Position
pos, [CHSToken]
toks'2)
        [CHSToken]
toks                                          -> forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
    (Maybe (Ident, CHSArg)
oomMarsh, [CHSToken]
toks'3) <- forall s. [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
parseOptMarsh [CHSToken]
toks'2
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
-> String -> Bool -> Maybe (Ident, CHSArg) -> Position -> CHSParm
CHSParm Maybe (Ident, CHSArg)
oimMarsh String
hsTyStr Bool
twoCVals Maybe (Ident, CHSArg)
oomMarsh Position
pos, [CHSToken]
toks'3)
  where
    parseOptMarsh :: [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
    parseOptMarsh :: forall s. [CHSToken] -> CST s (Maybe (Ident, CHSArg), [CHSToken])
parseOptMarsh (CHSTokIdent Position
_ Ident
ide:CHSTokStar Position
_ :[CHSToken]
toks) = 
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Ident
ide, CHSArg
CHSIOArg) , [CHSToken]
toks)
    parseOptMarsh (CHSTokIdent Position
_ Ident
ide:CHSTokMinus Position
_:[CHSToken]
toks) = 
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Ident
ide, CHSArg
CHSVoidArg), [CHSToken]
toks)
    parseOptMarsh (CHSTokIdent Position
_ Ident
ide              :[CHSToken]
toks) = 
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Ident
ide, CHSArg
CHSValArg) , [CHSToken]
toks)
    parseOptMarsh [CHSToken]
toks                                   =
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [CHSToken]
toks)

parseField :: Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField :: forall s. Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]
parseField Position
pos CHSAccess
access [CHSToken]
toks =
  do
    (CHSAPath
path, [CHSToken]
toks') <- forall s. [CHSToken] -> CST s (CHSAPath, [CHSToken])
parsePath  [CHSToken]
toks
    [CHSFrag]
frags         <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (CHSAccess -> CHSAPath -> Position -> CHSHook
CHSField CHSAccess
access CHSAPath
path Position
pos) forall a. a -> [a] -> [a]
: [CHSFrag]
frags

parsePointer :: Position -> [CHSToken] -> CST s [CHSFrag]
parsePointer :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parsePointer Position
pos [CHSToken]
toks =
  do
    (Bool
isStar, Ident
ide, [CHSToken]
toks')          <- 
      case [CHSToken]
toks of
        CHSTokStar Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks' -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True , Ident
ide, [CHSToken]
toks')
        CHSTokIdent Position
_ Ident
ide             :[CHSToken]
toks' -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Ident
ide, [CHSToken]
toks')
        [CHSToken]
_                                    -> forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
    (Maybe Ident
oalias , [CHSToken]
toks'2)             <- forall s.
Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
ide Bool
True [CHSToken]
toks'
    (CHSPtrType
ptrType, [CHSToken]
toks'3)             <- forall s. [CHSToken] -> CST s (CHSPtrType, [CHSToken])
parsePtrType        [CHSToken]
toks'2
    let 
     (Bool
isNewtype, Maybe Ident
oRefType, [CHSToken]
toks'4) =
      case [CHSToken]
toks'3 of
        CHSTokNewtype Position
_                  :[CHSToken]
toks' -> (Bool
True , forall a. Maybe a
Nothing , [CHSToken]
toks' )
        CHSTokArrow   Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks' -> (Bool
False, forall a. a -> Maybe a
Just Ident
ide, [CHSToken]
toks' )
        [CHSToken]
_                                       -> (Bool
False, forall a. Maybe a
Nothing , [CHSToken]
toks'3)
    [CHSToken]
toks'5                        <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks'4
    [CHSFrag]
frags                         <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags   [CHSToken]
toks'5
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 
      CHSHook -> CHSFrag
CHSHook 
       (Bool
-> Ident
-> Maybe Ident
-> CHSPtrType
-> Bool
-> Maybe Ident
-> Position
-> CHSHook
CHSPointer Bool
isStar Ident
ide (forall {a}. Eq a => a -> Maybe a -> Maybe a
norm Ident
ide Maybe Ident
oalias) CHSPtrType
ptrType Bool
isNewtype Maybe Ident
oRefType Position
pos)
       forall a. a -> [a] -> [a]
: [CHSFrag]
frags
  where
    parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken])
    parsePtrType :: forall s. [CHSToken] -> CST s (CHSPtrType, [CHSToken])
parsePtrType (CHSTokForeign Position
_:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return (CHSPtrType
CHSForeignPtr, [CHSToken]
toks)
    parsePtrType (CHSTokStable Position
_ :[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return (CHSPtrType
CHSStablePtr, [CHSToken]
toks)
    parsePtrType                  [CHSToken]
toks  = forall (m :: * -> *) a. Monad m => a -> m a
return (CHSPtrType
CHSPtr, [CHSToken]
toks)

    norm :: a -> Maybe a -> Maybe a
norm a
ide Maybe a
Nothing                   = forall a. Maybe a
Nothing
    norm a
ide (Just a
ide') | a
ide forall a. Eq a => a -> a -> Bool
== a
ide' = forall a. Maybe a
Nothing
                         | Bool
otherwise   = forall a. a -> Maybe a
Just a
ide'

parsePragma :: Position -> [CHSToken] -> CST s [CHSFrag]
parsePragma :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parsePragma Position
pos [CHSToken]
toks = do
  let
    parseExts :: [String]
-> [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
parseExts [String]
exts (CHSTokIdent Position
_ Ident
ide:CHSTokComma Position
_:[CHSToken]
toks) =
      [String]
-> [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
parseExts (Ident -> String
identToLexeme Ident
ideforall a. a -> [a] -> [a]
:[String]
exts) [CHSToken]
toks
    parseExts [String]
exts (CHSTokIdent Position
_ Ident
ide:CHSTokPragEnd Position
_:[CHSToken]
toks) =
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse (Ident -> String
identToLexeme Ident
ideforall a. a -> [a] -> [a]
:[String]
exts), [CHSToken]
toks)
    parseExts [String]
exts [CHSToken]
toks = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
  ([String]
exts, [CHSToken]
toks) <- forall {s}.
[String]
-> [CHSToken] -> PreCST SwitchBoard s ([String], [CHSToken])
parseExts [] [CHSToken]
toks
  [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks
  forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Position -> CHSFrag
CHSLang [String]
exts Position
pos forall a. a -> [a] -> [a]
: [CHSFrag]
frags)

parseClass :: Position -> [CHSToken] -> CST s [CHSFrag]
parseClass :: forall s. Position -> [CHSToken] -> CST s [CHSFrag]
parseClass Position
pos (CHSTokIdent  Position
_ Ident
sclassIde:
                CHSTokDArrow Position
_          :
                CHSTokIdent  Position
_ Ident
classIde :
                CHSTokIdent  Position
_ Ident
typeIde  :
                [CHSToken]
toks)                     =
  do
    [CHSToken]
toks' <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
    [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Maybe Ident -> Ident -> Ident -> Position -> CHSHook
CHSClass (forall a. a -> Maybe a
Just Ident
sclassIde) Ident
classIde Ident
typeIde Position
pos) forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseClass Position
pos (CHSTokIdent Position
_ Ident
classIde :
                CHSTokIdent Position
_ Ident
typeIde  :
                [CHSToken]
toks)                     =
  do
    [CHSToken]
toks' <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
    [CHSFrag]
frags <- forall s. [CHSToken] -> CST s [CHSFrag]
parseFrags [CHSToken]
toks'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CHSHook -> CHSFrag
CHSHook (Maybe Ident -> Ident -> Ident -> Position -> CHSHook
CHSClass forall a. Maybe a
Nothing Ident
classIde Ident
typeIde Position
pos) forall a. a -> [a] -> [a]
: [CHSFrag]
frags
parseClass Position
_ [CHSToken]
toks = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks

parseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLib :: forall s. [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLib (CHSTokLib    Position
_    :
             CHSTokEqual  Position
_    :
             CHSTokString Position
_ String
str:
             [CHSToken]
toks)                = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just String
str, [CHSToken]
toks)
parseOptLib (CHSTokLib Position
_:[CHSToken]
toks   ) = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptLib [CHSToken]
toks                  = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [CHSToken]
toks)

parseOptLock :: [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLock :: forall s. [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptLock (CHSTokLock   Position
_    :
              CHSTokEqual  Position
_    :
              CHSTokString Position
_ String
str:
              [CHSToken]
toks)               = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just String
str, [CHSToken]
toks)
parseOptLock (CHSTokLock Position
_:[CHSToken]
toks ) = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptLock [CHSToken]
toks                 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [CHSToken]
toks)

parseOptPrefix :: Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix :: forall s. Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])
parseOptPrefix Bool
False (CHSTokPrefix Position
_    :
                      CHSTokEqual  Position
_    :
                      CHSTokString Position
_ String
str:
                      [CHSToken]
toks)                = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just String
str, [CHSToken]
toks)
parseOptPrefix Bool
True  (CHSTokWith   Position
_    :
                      CHSTokPrefix Position
_    :
                      CHSTokEqual  Position
_    :
                      CHSTokString Position
_ String
str:
                      [CHSToken]
toks)                = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just String
str, [CHSToken]
toks)
parseOptPrefix Bool
_     (CHSTokWith   Position
_:[CHSToken]
toks) = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptPrefix Bool
_     (CHSTokPrefix Position
_:[CHSToken]
toks) = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptPrefix Bool
_     [CHSToken]
toks                  = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [CHSToken]
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 :: forall s.
Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])
parseOptAs Ident
_   Bool
_     (CHSTokAs Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) = 
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Ident
ide, [CHSToken]
toks)
parseOptAs Ident
ide Bool
upper (CHSTokAs Position
_:CHSTokHat Position
pos    :[CHSToken]
toks) = 
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Ident -> Bool -> Position -> Ident
underscoreToCase Ident
ide Bool
upper Position
pos, [CHSToken]
toks)
parseOptAs Ident
_   Bool
_     (CHSTokAs Position
_                  :[CHSToken]
toks) = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseOptAs Ident
_   Bool
_                                   [CHSToken]
toks  = 
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, [CHSToken]
toks)

-- convert C style identifier to Haskell style identifier
--
underscoreToCase               :: Ident -> Bool -> Position -> Ident
underscoreToCase :: Ident -> Bool -> Position -> Ident
underscoreToCase Ident
ide Bool
upper Position
pos  = 
  let lexeme :: String
lexeme = Ident -> String
identToLexeme Ident
ide
      ps :: [String]
ps     = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
parts forall a b. (a -> b) -> a -> b
$ String
lexeme
  in
  Position -> String -> Ident
onlyPosIdent Position
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
adjustHead forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ShowS
adjustCase forall a b. (a -> b) -> a -> b
$ [String]
ps
  where
    parts :: String -> [String]
parts String
s = let (String
l, String
s') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'_') String
s
              in  
              String
l forall a. a -> [a] -> [a]
: case String
s' of
                    []      -> []
                    (Char
_:String
s'') -> String -> [String]
parts String
s''
    --    
    adjustCase :: ShowS
adjustCase (Char
c:String
cs) = Char -> Char
toUpper Char
c forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
cs
    --
    adjustHead :: ShowS
adjustHead String
""     = String
""
    adjustHead (Char
c:String
cs) = if Bool
upper then Char -> Char
toUpper Char
c forall a. a -> [a] -> [a]
: String
cs else Char -> Char
toLower Char
cforall a. a -> [a] -> [a]
:String
cs

-- this is disambiguated and left factored
--
parsePath :: [CHSToken] -> CST s (CHSAPath, [CHSToken])
parsePath :: forall s. [CHSToken] -> CST s (CHSAPath, [CHSToken])
parsePath (CHSTokStar Position
pos:[CHSToken]
toks) =
  do
    (CHSAPath
path, [CHSToken]
toks') <- forall s. [CHSToken] -> CST s (CHSAPath, [CHSToken])
parsePath [CHSToken]
toks
    forall (m :: * -> *) a. Monad m => a -> m a
return (CHSAPath -> Position -> CHSAPath
CHSDeref CHSAPath
path Position
pos, [CHSToken]
toks')
parsePath (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
  do
    (CHSAPath -> CHSAPath
pathWithHole, [CHSToken]
toks') <- forall s. [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' [CHSToken]
toks
    forall (m :: * -> *) a. Monad m => a -> m a
return (CHSAPath -> CHSAPath
pathWithHole (Ident -> CHSAPath
CHSRoot Ident
ide), [CHSToken]
toks')
parsePath [CHSToken]
toks = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks

-- `s->m' is represented by `(*s).m' in the tree
--
parsePath' :: [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' :: forall s. [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' (CHSTokDot Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
  do
    (CHSAPath -> CHSAPath
pathWithHole, [CHSToken]
toks') <- forall s. [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' [CHSToken]
toks
    forall (m :: * -> *) a. Monad m => a -> m a
return (CHSAPath -> CHSAPath
pathWithHole forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\CHSAPath
hole -> CHSAPath -> Ident -> CHSAPath
CHSRef CHSAPath
hole Ident
ide), [CHSToken]
toks')
parsePath' (CHSTokDot Position
_:[CHSToken]
toks) = 
  forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parsePath' (CHSTokArrow Position
pos:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
  do
    (CHSAPath -> CHSAPath
pathWithHole, [CHSToken]
toks') <- forall s. [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])
parsePath' [CHSToken]
toks
    forall (m :: * -> *) a. Monad m => a -> m a
return (CHSAPath -> CHSAPath
pathWithHole forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\CHSAPath
hole -> CHSAPath -> Ident -> CHSAPath
CHSRef (CHSAPath -> Position -> CHSAPath
CHSDeref CHSAPath
hole Position
pos) Ident
ide), [CHSToken]
toks')
parsePath' (CHSTokArrow Position
_:[CHSToken]
toks) = 
  forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parsePath' [CHSToken]
toks =
  do
    [CHSToken]
toks' <- forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook [CHSToken]
toks
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> a
id, [CHSToken]
toks')

parseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken])
parseTrans :: forall s. [CHSToken] -> CST s (CHSTrans, [CHSToken])
parseTrans (CHSTokLBrace Position
_:[CHSToken]
toks) =
  do
    (Bool
_2Case, [CHSToken]
toks' ) <- forall {m :: * -> *}. Monad m => [CHSToken] -> m (Bool, [CHSToken])
parse_2Case [CHSToken]
toks
    case [CHSToken]
toks' of
      (CHSTokRBrace Position
_:[CHSToken]
toks'') -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [(Ident, Ident)] -> CHSTrans
CHSTrans Bool
_2Case [], [CHSToken]
toks'')
      [CHSToken]
_                       ->
        do
          -- if there was no `underscoreToCase', we add a comma token to meet
          -- the invariant of `parseTranss'
          --
          ([(Ident, Ident)]
transs, [CHSToken]
toks'') <- if Bool
_2Case 
                              then forall {s}.
[CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
parseTranss [CHSToken]
toks'
                              else forall {s}.
[CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
parseTranss (Position -> CHSToken
CHSTokComma Position
noposforall a. a -> [a] -> [a]
:[CHSToken]
toks')
          forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [(Ident, Ident)] -> CHSTrans
CHSTrans Bool
_2Case [(Ident, Ident)]
transs, [CHSToken]
toks'')
  where
    parse_2Case :: [CHSToken] -> m (Bool, [CHSToken])
parse_2Case (CHSTok_2Case Position
_:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, [CHSToken]
toks)
    parse_2Case [CHSToken]
toks                  = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [CHSToken]
toks)
    --
    parseTranss :: [CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
parseTranss (CHSTokRBrace Position
_:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
    parseTranss (CHSTokComma  Position
_:[CHSToken]
toks) = do
                                          ((Ident, Ident)
assoc, [CHSToken]
toks' ) <- forall {s}.
[CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
parseAssoc [CHSToken]
toks
                                          ([(Ident, Ident)]
trans, [CHSToken]
toks'') <- [CHSToken] -> PreCST SwitchBoard s ([(Ident, Ident)], [CHSToken])
parseTranss [CHSToken]
toks'
                                          forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident, Ident)
assocforall a. a -> [a] -> [a]
:[(Ident, Ident)]
trans, [CHSToken]
toks'')
    parseTranss [CHSToken]
toks                  = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
    --
    parseAssoc :: [CHSToken] -> PreCST SwitchBoard s ((Ident, Ident), [CHSToken])
parseAssoc (CHSTokIdent Position
_ Ident
ide1:CHSTokAs Position
_:CHSTokIdent Position
_ Ident
ide2:[CHSToken]
toks) =
      forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident
ide1, Ident
ide2), [CHSToken]
toks)
    parseAssoc (CHSTokIdent Position
_ Ident
ide1:CHSTokAs Position
_:[CHSToken]
toks                   ) =
      forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
    parseAssoc (CHSTokIdent Position
_ Ident
ide1:[CHSToken]
toks                              ) =
      forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
    parseAssoc [CHSToken]
toks                                                    =
      forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks
parseTrans [CHSToken]
toks = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks

parseDerive :: [CHSToken] -> CST s ([Ident], [CHSToken])
parseDerive :: forall s. [CHSToken] -> CST s ([Ident], [CHSToken])
parseDerive (CHSTokDerive Position
_ :CHSTokLParen Position
_:CHSTokRParen Position
_:[CHSToken]
toks) = 
  forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseDerive (CHSTokDerive Position
_ :CHSTokLParen Position
_:[CHSToken]
toks)                = 
  forall s. [CHSToken] -> CST s ([Ident], [CHSToken])
parseCommaIdent (Position -> CHSToken
CHSTokComma Position
noposforall a. a -> [a] -> [a]
:[CHSToken]
toks)
  where
    parseCommaIdent :: [CHSToken] -> CST s ([Ident], [CHSToken])
    parseCommaIdent :: forall s. [CHSToken] -> CST s ([Ident], [CHSToken])
parseCommaIdent (CHSTokComma Position
_:CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) =
      do
        ([Ident]
ids, [CHSToken]
tok') <- forall s. [CHSToken] -> CST s ([Ident], [CHSToken])
parseCommaIdent [CHSToken]
toks
        forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ideforall a. a -> [a] -> [a]
:[Ident]
ids, [CHSToken]
tok')
    parseCommaIdent (CHSTokRParen Position
_                 :[CHSToken]
toks) = 
      forall (m :: * -> *) a. Monad m => a -> m a
return ([], [CHSToken]
toks)
parseDerive [CHSToken]
toks = forall (m :: * -> *) a. Monad m => a -> m a
return ([],[CHSToken]
toks)

parseIdent :: [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent :: forall s. [CHSToken] -> CST s (Ident, [CHSToken])
parseIdent (CHSTokIdent Position
_ Ident
ide:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ide, [CHSToken]
toks)
parseIdent [CHSToken]
toks                     = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks

parseEndHook :: [CHSToken] -> CST s ([CHSToken])
parseEndHook :: forall s. [CHSToken] -> CST s [CHSToken]
parseEndHook (CHSTokEndHook Position
_:[CHSToken]
toks) = forall (m :: * -> *) a. Monad m => a -> m a
return [CHSToken]
toks
parseEndHook [CHSToken]
toks                   = forall s a. [CHSToken] -> CST s a
syntaxError [CHSToken]
toks

syntaxError         :: [CHSToken] -> CST s a
syntaxError :: forall s a. [CHSToken] -> CST s a
syntaxError []       = forall s a. CST s a
errorEOF
syntaxError (CHSToken
tok:[CHSToken]
_)  = forall s a. CHSToken -> CST s a
errorIllegal CHSToken
tok

errorIllegal     :: CHSToken -> CST s a
errorIllegal :: forall s a. CHSToken -> CST s a
errorIllegal CHSToken
tok  = do
                      forall e s. Position -> [String] -> PreCST e s ()
raiseError (forall a. Pos a => a -> Position
posOf CHSToken
tok)
                        [String
"Syntax error!",
                         String
"The phrase `" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CHSToken
tok forall a. [a] -> [a] -> [a]
++ String
"' is not allowed \
                         \here."]
                      forall s a. CST s a
raiseSyntaxError

errorEOF :: CST s a
errorEOF :: forall s a. CST s a
errorEOF  = do
              forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos 
                [String
"Premature end of file!",
                 String
"The .chs file ends in the middle of a binding hook."]
              forall s a. CST s a
raiseSyntaxError

errorCHINotFound     :: String -> CST s a
errorCHINotFound :: forall s a. String -> CST s a
errorCHINotFound String
ide  = do
  forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos 
    [String
"Unknown .chi file!",
     String
"Cannot find the .chi file for `" forall a. [a] -> [a] -> [a]
++ String
ide forall a. [a] -> [a] -> [a]
++ String
"'."]
  forall s a. CST s a
raiseSyntaxError

errorCHICorrupt      :: String -> CST s a
errorCHICorrupt :: forall s a. String -> CST s a
errorCHICorrupt String
ide  = do
  forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos 
    [String
"Corrupt .chi file!",
     String
"The file `" forall a. [a] -> [a] -> [a]
++  String
ide forall a. [a] -> [a] -> [a]
++ String
".chi' is corrupt."]
  forall s a. CST s a
raiseSyntaxError

errorCHIVersion :: String -> String -> String -> CST s a
errorCHIVersion :: forall s a. String -> String -> String -> CST s a
errorCHIVersion String
ide String
chiVersion String
myVersion  = do
  forall e s. Position -> [String] -> PreCST e s ()
raiseError Position
nopos 
    [String
"Wrong version of .chi file!",
     String
"The file `" forall a. [a] -> [a] -> [a]
++ String
ide forall a. [a] -> [a] -> [a]
++ String
".chi' is version " 
     forall a. [a] -> [a] -> [a]
++ String
chiVersion forall a. [a] -> [a] -> [a]
++ String
", but mine is " forall a. [a] -> [a] -> [a]
++ String
myVersion forall a. [a] -> [a] -> [a]
++ String
"."]
  forall s a. CST s a
raiseSyntaxError