--  C->Haskell Compiler: monad for the binding generator
--
--  Author : Manuel M T Chakravarty
--  Derived: 18 February 2 (extracted from GenBind.hs)
--
--  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $
--
--  Copyright (c) [2002..2003] 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 ---------------------------------------------------------------
--
--  This modules defines the monad and related utility routines for the code
--  that implements the expansion of the binding hooks.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  Translation table handling for enumerators:
--  -------------------------------------------
--
--  First a translation table lookup on the original identifier of the
--  enumerator is done.  If that doesn't match and the prefix can be removed
--  from the identifier, a second lookup on the identifier without the prefix
--  is performed.  If this also doesn't match, the identifier without prefix
--  (possible after underscoreToCase translation is returned).  If there is a
--  match, the translation (without any further stripping of prefix) is
--  returned.  
--
--  Pointer map
--  -----------
--
--  Pointer hooks allow the use to customise the Haskell types to which C
--  pointer types are mapped.  The globally maintained map essentially maps C
--  pointer types to Haskell pointer types.  The representation of the Haskell
--  types is defined by the `type' or `newtype' declaration emitted by the
--  corresponding pointer hook.  However, the map stores a flag that tells
--  whether the C type is itself the pointer type in question or whether it is
--  pointers to this C type that should be mapped as specified.  The pointer
--  map is dumped into and read from `.chi' files.
--
--  Haskell object map
--  ------------------
--
--  Some features require information about Haskell objects defined by c2hs.
--  Therefore, the Haskell object map maintains the necessary information
--  about these Haskell objects.  The Haskell object map is dumped into and
--  read from `.chi' files.
--
--- TODO ----------------------------------------------------------------------
--
--  * Look up in translation tables is naive - this probably doesn't affect
--    costs much, but at some point a little profiling might be beneficial.
--

module GBMonad (
  TransFun, transTabToTransFun,

  HsObject(..), GB, HsPtrRep, initialGBState, setContext, getLibrary,
  getPrefix, getLock, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,
  queryObj, queryClass, queryPointer, mergeMaps, dumpMaps
  ) where

-- standard libraries
import Data.Char          (toUpper, toLower, isSpace)
import Data.List       (find)
import Data.Maybe         (fromMaybe)

-- Compiler Toolkit
import Position   (Position, Pos(posOf), nopos, builtinPos)
import Errors     (interr)
import Idents     (Ident, identToLexeme, onlyPosIdent)
import Map        (Map)
import qualified  Map as Map (empty, insert, lookup, fromList, toList, union)

-- C -> Haskell
import C          (CT, readCT, transCT, raiseErrorCTExc)

-- friends
import CHS        (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),
                   CHSAccess(..), CHSAPath(..), CHSPtrType(..))


-- translation tables
-- ------------------

-- takes an identifier to a lexeme including a potential mapping by a
-- translation table
--
type TransFun = Ident -> String

-- translation function for the `underscoreToCase' flag
--
underscoreToCase     :: TransFun
underscoreToCase ide  = let lexeme = identToLexeme ide
                            ps     = filter (not . null) . parts $ lexeme
                        in
                        concat . map adjustCase $ ps
                        where
                          parts s = let (l, s') = break (== '_') s
                                    in  
                                    l : case s' of
                                          []      -> []
                                          (_:s'') -> parts s''
                          
                          adjustCase (c:cs) = toUpper c : map toLower cs

-- takes an identifier association table to a translation function
--
--  * if first argument is `True', identifiers that are not found in the
--   translation table are subjected to `underscoreToCase'
--
--  * the details of handling the prefix are given in the DOCU section at the
--   beginning of this file
--
transTabToTransFun :: String -> CHSTrans -> TransFun
transTabToTransFun prefix (CHSTrans _2Case table) =
  \ide -> let 
            lexeme = identToLexeme ide
            dft    = if _2Case                  -- default uses maybe the...
                     then underscoreToCase ide  -- ..._2case transformed...
                     else lexeme                -- ...lexeme
          in
          case lookup ide table of                  -- lookup original ident
            Just ide' -> identToLexeme ide'         -- original ident matches
            Nothing   -> 
              case eat prefix lexeme of
                Nothing          -> dft             -- no match & no prefix
                Just eatenLexeme -> 
                  let 
                    eatenIde = onlyPosIdent (posOf ide) eatenLexeme
                    eatenDft = if _2Case 
                               then underscoreToCase eatenIde 
                               else eatenLexeme
                  in
                  case lookup eatenIde table of     -- lookup without prefix
                    Nothing   -> eatenDft           -- orig ide without prefix
                    Just ide' -> identToLexeme ide' -- without prefix matched
  where
    -- try to eat prefix and return `Just partialLexeme' if successful
    --
    eat []         ('_':cs)                        = eat [] cs
    eat []         cs                              = Just cs
    eat (p:prefix) (c:cs) | toUpper p == toUpper c = eat prefix cs
                          | otherwise              = Nothing
    eat _          _                               = Nothing


-- the local monad
-- ---------------

-- map that for maps C pointer types to Haskell types for pointer that have
-- been registered using a pointer hook
--
--  * the `Bool' indicates whether for a C type "ctype", we map "ctype" itself
--   or "*ctype"
--
--  * the co-domain details how this pointer is represented in Haskell.
--   See HsPtrRep.
--
type PointerMap = Map (Bool, Ident) HsPtrRep


-- Define how pointers are represented in Haskell.
--
--  * The first element is true if the pointer points to a function.
--   The second is the Haskell pointer type (plain
--   Ptr, ForeignPtr or StablePtr). The third field is (Just wrap) if the
--   pointer is wrapped in a newtype. Where "wrap" 
--   contains the name of the Haskell data type that was defined for this
--   pointer. The forth element contains the type argument of the
--   Ptr, ForeignPtr or StablePtr and is the same as "wrap"
--   unless the user overrode it with the -> notation.
type HsPtrRep = (Bool, CHSPtrType, Maybe String, String)


-- map that maintains key information about some of the Haskell objects
-- generated by c2hs
--
-- NB: using records here avoids to run into a bug with deriving `Read' in GHC
--     5.04.1
--
data HsObject    = Pointer {
                     ptrTypeHO    :: CHSPtrType,   -- kind of pointer
                     isNewtypeHO  :: Bool          -- newtype?
                   }
                 | Class {
                     superclassHO :: (Maybe Ident),-- superclass
                     ptrHO        :: Ident         -- pointer
                   }
                 deriving (Show, Read)
type HsObjectMap = Map Ident HsObject

{- FIXME: What a mess...
instance Show HsObject where
  show (Pointer ptrType isNewtype) = 
    "Pointer " ++ show ptrType ++ show isNewtype
  show (Class   osuper  pointer  ) = 
    "Class " ++ show ptrType ++ show isNewtype
-}
-- super kludgy (depends on Show instance of Ident)
instance Read Ident where
  readsPrec _ ('`':lexeme) = let (ideChars, rest) = span (/= '\'') lexeme
                             in
                             if null ideChars 
                             then []
                             else [(onlyPosIdent nopos ideChars, tail rest)]
  readsPrec p (c:cs)
    | isSpace c                                              = readsPrec p cs
  readsPrec _ _                                              = []

-- the local state consists of
--
-- (1) the dynamic library specified by the context hook,
-- (2) the prefix specified by the context hook,
-- (3) an optional wrapper function that acquires a lock, this may also
--     be specified on the command line
-- (3) the set of delayed code fragaments, ie, pieces of Haskell code that,
--     finally, have to be appended at the CHS module together with the hook
--     that created them (the latter allows avoid duplication of foreign
--     export declarations), and
-- (4) a map associating C pointer types with their Haskell representation
--     
-- access to the attributes of the C structure tree is via the `CT' monad of
-- which we use an instance here
--
data GBState  = GBState {
                  lib     :: String,               -- dynamic library
                  prefix  :: String,               -- prefix
                  mLock   :: Maybe String,         -- a lock function
                  frags   :: [(CHSHook, CHSFrag)], -- delayed code (with hooks)
                  ptrmap  :: PointerMap,           -- pointer representation
                  objmap  :: HsObjectMap           -- generated Haskell objects
               }

type GB a = CT GBState a

initialGBState :: Maybe String -> GBState
initialGBState mLock = GBState {
    lib    = "",
    prefix = "",
    mLock = mLock,
    frags  = [],
    ptrmap = Map.empty,
    objmap = Map.empty
  }

-- set the dynamic library and library prefix
--
setContext            :: (Maybe String) -> (Maybe String) -> (Maybe String) ->
                         GB ()
setContext lib prefix newMLock = 
  transCT $ \state -> (state {lib    = fromMaybe "" lib,
                              prefix = fromMaybe "" prefix,
                              mLock  = case newMLock of
                                         Nothing -> mLock state
                                         Just _ -> newMLock },
                       ())

-- get the dynamic library
--
getLibrary :: GB String
getLibrary  = readCT lib

-- get the prefix string
--
getPrefix :: GB String
getPrefix  = readCT prefix

-- get the lock function
getLock :: GB (Maybe String)
getLock = readCT mLock

-- add code to the delayed fragments (the code is made to start at a new line)
--
--  * currently only code belonging to call hooks can be delayed
--
--  * if code for the same call hook (ie, same C function) is delayed
--   repeatedly only the first entry is stored; it is checked that the hooks
--   specify the same flags (ie, produce the same delayed code)
--
delayCode          :: CHSHook -> String -> GB ()
delayCode hook str  = 
  do
    frags <- readCT frags
    frags' <- delay hook frags
    transCT (\state -> (state {frags = frags'}, ()))
    where
      newEntry = (hook, (CHSVerb ("\n" ++ str) (posOf hook)))
      --
      delay hook@(CHSCall isFun isUns _ ide oalias _) frags =
        case find (\(hook', _) -> hook' == hook) frags of
          Just (CHSCall isFun' isUns' _ ide' _ _, _) 
            |    isFun == isFun' 
              && isUns == isUns'
              && ide   == ide'   -> return frags
            | otherwise          -> err (posOf ide) (posOf ide')
          Nothing                -> return $ frags ++ [newEntry]
      delay _ _                                  =
        interr "GBMonad.delayCode: Illegal delay!"
      --
      err = incompatibleCallHooksErr

-- get the complete list of delayed fragments
--
getDelayedCode :: GB [CHSFrag]
getDelayedCode  = readCT (map snd . frags)

-- add an entry to the pointer map
--
ptrMapsTo :: (Bool, Ident) -> HsPtrRep -> GB ()
(isStar, cName) `ptrMapsTo` hsRepr =
  transCT (\state -> (state { 
                        ptrmap = Map.insert (isStar, cName) hsRepr (ptrmap state)
                      }, ()))

-- query the pointer map
--
queryPtr        :: (Bool, Ident) -> GB (Maybe HsPtrRep)
queryPtr pcName  = do
                     fm <- readCT ptrmap
                     return $ Map.lookup pcName fm

-- add an entry to the Haskell object map
--
objIs :: Ident -> HsObject -> GB ()
hsName `objIs` obj =
  transCT (\state -> (state { 
                        objmap = Map.insert hsName obj (objmap state)
                      }, ()))

-- query the Haskell object map
--
queryObj        :: Ident -> GB (Maybe HsObject)
queryObj hsName  = do
                     fm <- readCT objmap
                     return $ Map.lookup hsName fm

-- query the Haskell object map for a class
--
--  * raise an error if the class cannot be found
--
queryClass        :: Ident -> GB HsObject
queryClass hsName  = do
                       let pos = posOf hsName
                       oobj <- queryObj hsName
                       case oobj of
                         Just obj@(Class _ _) -> return obj
                         Just _               -> classExpectedErr hsName
                         Nothing              -> hsObjExpectedErr hsName

-- query the Haskell object map for a pointer
--
--  * raise an error if the pointer cannot be found
--
queryPointer        :: Ident -> GB HsObject
queryPointer hsName  = do
                       let pos = posOf hsName
                       oobj <- queryObj hsName
                       case oobj of
                         Just obj@(Pointer _ _) -> return obj
                         Just _                 -> pointerExpectedErr hsName
                         Nothing                -> hsObjExpectedErr hsName

-- merge the pointer and Haskell object maps
--
--  * currently, the read map overrides any entries for shared keys in the map
--   that is already in the monad; this is so that, if multiple import hooks
--   add entries for shared keys, the textually latest prevails; any local
--   entries are entered after all import hooks anyway
--
-- FIXME: This currently has several shortcomings:
--        * It just dies in case of a corrupted .chi file
--        * We should at least have the option to raise a warning if two
--          entries collide in the `objmap'.  But it would be better to
--          implement qualified names.
--        * Do we want position information associated with the read idents?
--
mergeMaps     :: String -> GB ()
mergeMaps str  =
  transCT (\state -> (state { 
                        ptrmap = Map.union (ptrmap state) readPtrMap,
                        objmap = Map.union (objmap state) readObjMap
                      }, ()))
  where
    (ptrAssoc, objAssoc) = read str
    readPtrMap           = Map.fromList [((isStar, onlyPosIdent nopos ide), repr)
                                    | ((isStar, ide), repr) <- ptrAssoc]
    readObjMap           = Map.fromList [(onlyPosIdent nopos ide, obj)
                                    | (ide, obj)            <- objAssoc]

-- convert the whole pointer and Haskell object maps into printable form
--
dumpMaps :: GB String
dumpMaps  = do
              ptrFM <- readCT ptrmap
              objFM <- readCT objmap
              let dumpable = ([((isStar, identToLexeme ide), repr)
                              | ((isStar, ide), repr) <- Map.toList ptrFM],
                              [(identToLexeme ide, obj)
                              | (ide, obj)            <- Map.toList objFM])
              return $ show dumpable


-- error messages
-- --------------

incompatibleCallHooksErr            :: Position -> Position -> GB a
incompatibleCallHooksErr here there  =
  raiseErrorCTExc here 
    ["Incompatible call hooks!",
     "There is a another call hook for the same C function at " ++ show there,
     "The flags and C function name of the two hooks should be identical,",
     "but they are not."]

classExpectedErr     :: Ident -> GB a
classExpectedErr ide  =
  raiseErrorCTExc (posOf ide)
    ["Expected a class name!",
     "Expected `" ++ identToLexeme ide ++ "' to refer to a class introduced",
     "by a class hook."]

pointerExpectedErr     :: Ident -> GB a
pointerExpectedErr ide  =
  raiseErrorCTExc (posOf ide)
    ["Expected a pointer name!",
     "Expected `" ++ identToLexeme ide ++ "' to be a type name introduced by",
     "a pointer hook."]

hsObjExpectedErr     :: Ident -> GB a
hsObjExpectedErr ide  =
  raiseErrorCTExc (posOf ide)
    ["Unknown name!",
     "`" ++ identToLexeme ide ++ "' is unknown; it has *not* been defined by",
     "a previous hook."]

