PrettyPrinting.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Pretty printing function for the internal datastructures
--
-----------------------------------------------------------------------------

module WinDll.Structs.PrettyPrinting where

import WinDll.Structs.Structures
import WinDll.Structs.MShow.HaskellSrcExts
import WinDll.Structs.MShow.MShow
import WinDll.Lib.NativeMapping
import WinDll.Version ( verStr )

import Data.Foldable (foldl')
import Data.List(isPrefixOf,sort)

instance Show Export where
    showsPrec d (Export name exported types _) = 
        showString "foreign export stdcall " .
        showString (show exported)           .
        showString " "                       .
        showString name                      .
        showString " :: "                   .
        showString (mshow types)
          
        
instance Show Header where
    showsPrec d (Header name exports) =
        showString "-- | Autogenerated by WinDll, Do not change unless you know what you're doing \n" .
        showString "module "                .
        showString (name++"FFI")            .
        (if null exports 
            then id
            else (showString "(" .
                  showString 
                    (foldl1 (\a b->a++", "++b) exports) .
                  showString ")"))          .
        showString " where"
        
instance Show Function where
    showsPrec d (Function name argc types _ _) =
        showString name                      .
        showString " :: "                    .
        showString (mshow types)             .  
        showString "\n"                      .
        showString name                      .
        showString " "                       .
        showString (unwords args)            .
        showString " = toFFI $ "             .
        showString name                      .
        showString " "                       .
        showString (unwords $ map (\a->"(fromFFI "++a++")") args)
       where args = (zipWith ((. show) . (++)) (replicate argc "a") [1..])
       
instance Show DataType where
    showsPrec d (NewType name types body tag)  =
        printData True d name types [body]
    showsPrec d (DataType name types body tag) =
        printData False d name types body
    showsPrec d (Constr name types) = 
        showString name                     .
        showString " "                      .
        showString (mshow types)
        
-- | used above to abstract between dataypes and newtypes
printData nbe d name types body = 
        showString (if nbe then 
                    "newtype " else
                    "data ")                .
        showString name                     .
        showString " "                      .
        showString (unwords types)          .
        showString " = "                    .
        (mkBody body)                       .
        showString "\ntype "                .
        showString name                     .
        showString " "                      .
        showString (unwords types)          .
        (if null types 
           then showString " = Ptr "
           else showString " = Ptr (")      .
        showString name                     .
        (if null types then id
            else showString " "             .
                 showString (unwords types) .
                 showString ")")
       where indent = length name + 2 * (length types) + 7
             space  = replicate indent ' '
             mkConst a = showString "\n"    .
                         showString space   . 
                         showString "| "    .
                         showsPrec d a
             mkBody []     = id
             mkBody (x:xs) = showString "" . showsPrec d x . (foldl' (.) id (map mkConst xs))
        
instance Show Module where
    showsPrec d (Module header path imports exports datatypes functions _ _) =
        showsPrec d header                                      .
        showString "\n\n-- @@Generated from \""                 .
        showString path                                         .
        showString ("\" by WinDll version " ++ verStr ++ " \n") .
        showString (unlines $ map mkImport (sort imports))      .
        showString "\n"                                         .
        showString (mkPrec exports "")                          .
        showString "\n"                                         .
        --showString (mkPrec datatypes "\n")                    .
        --showString "\n"                                       .
        showString (mkPrec functions "\n")        
      where mkImport p = "import " ++ p
            mkPrec p0 v  = (unlines (map (\a->(showsPrec d a) v) p0))
        
-- | FFI Types need to be strict, This converts the type if needed
mkStrict :: TypeName -> TypeName
mkStrict a = if "!" `isPrefixOf` a then a else "!"++a
    
-- | Look up and convert the list of types back to a function signature to be printed. 
-- Admittedly this only supports simple functions, but these are enough for now (I don't know how FFI deals with functions as arguments)
showTypes :: String -> [TypeName] -> String
showTypes _ []     = []
showTypes f types  = foldl1 (\a b->a++f++b) types

-- | Generate the export list from the given module.
generateExportList :: Module -> String
generateExportList (Module _ _ _ export _ _ _ _) = showString "EXPORTS\n" (unlines list)
  where gmap f []                = []
        gmap f ((Export n _ _ _):xs) = f n:gmap f xs
        nums = [1..(length export)]
        list = (zipWith ($) (gmap (\a b->"\t"++a++"\t@"++show b) export) nums)