Pragma.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- This module contains the basic Pragma processing functions
-- to handle custom pragmas. Or specifically, those updating
-- the lookup lists.
--
-----------------------------------------------------------------------------

module WinDll.Utils.Pragma where

import WinDll.Session
import WinDll.Utils.Feedback
import WinDll.Structs.Structures
import WinDll.Lib.Native

-- | Retreive the pragmas matching the given directive
getPragmas :: String -> [Pragma] -> [Pragma]
getPragmas str = filter (\(Pragma s _)->s==str)

-- | Validate a pragma based on the given mask. '#' are taken to be a 
--   single string entry, spaces indicate a next element. 
--   The mask "# #@#" is taken as two elements, where the second one 
--   consists of two strings seperated by a @ sign.
validate :: String -> Pragma -> Exec Pragma
validate mask p@(Pragma nm ld) 
 = do guard (not $ isValid (words mask) ld) >>
         (die $   "Syntax error in Pragma " ++ nm ++ ", supplied value '" 
                ++ unwords ld ++ "' does not match mask '" ++ mask ++ "'")
      return p
 where isValid :: [String] -> [String] -> Bool
       isValid []     []     = True
       isValid (x:xs) (y:ys) = cmp x y && isValid xs ys
       isValid _      _      = False
       
       cmp :: String -> String -> Bool
       cmp ('#':xs) str       = let (fs, sn) = span (/='@') str
                                in cmp xs sn
       cmp ('@':xs) ('@':str) = cmp xs str
       cmp []       []        = True
       cmp _        _         = False

-- | Process the four convertion pragmas and create the 
--   proper conversion sets
processConversionPragmas :: [Pragma] -> Session -> Exec Session
processConversionPragmas prg session 
   = do hs2c  <- mapM (validate "# #@#") $ getPragmas "HS2C"  prg
        hs2cs <- mapM (validate "# #"  ) $ getPragmas "HS2C#" prg
        hs2hs <- mapM (validate "# #"  ) $ getPragmas "HS2HS" prg
        
        put session
        updateFromPragma hs2c  updt1 (\x y->y{n_hs2c =x ++ nativeLisths2c})
        updateFromPragma hs2c  updt2 (\x y->y{n_csize=x ++ nativeC_sizes})
        updateFromPragma hs2cs updt3 (\x y->y{n_hs2cs= \b -> x ++ nativeCslist b})
        updateFromPragma hs2hs updt4 (\x y->y{n_hs2hs=x ++ nativeConvList})
        get
 where updt1 [x,y] = (x, takeWhile (/='@') y)
       updt2 [x,y] = (x, read $ tail (dropWhile (/='@') y))
       updt3 [x,y] = (x, y)
       updt4 [x,y] = (x, y)
      
-- | Update a session by processing the values inside the given Pragmas
updateFromPragma :: [Pragma] -> ([String] -> (a, b)) -> ([(a, b)] -> WorkingSet -> WorkingSet) -> Exec ()
updateFromPragma prg process update 
   = do session <- get
        let results = map (\(Pragma _ lst)->process lst) prg
        let wrk = update results (workingset session)
        put $ session{workingset = wrk}