content: {-
      Copyright 2015 Markus Ongyerth, Stephan Guenther
  
      This file is part of Monky.
  
      Monky is free software: you can redistribute it and/or modify
      it under the terms of the GNU Lesser General Public License as published by
      the Free Software Foundation, either version 3 of the License, or
      (at your option) any later version.
  
      Monky 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 Lesser General Public License for more details.
  
      You should have received a copy of the GNU Lesser General Public License
      along with Monky.  If not, see <http://www.gnu.org/licenses/>.
  -}
  {-# LANGUAGE CPP, TemplateHaskell #-}
  {-|
  Module      : Monky.Template
  Description : This module provides a template haskell splice for including librarys
  Maintainer  : ongy, moepi
  Stability   : testing
  Portability : Linux
  
  This module is intended to be used by Monky modules, /not/ for configuration.
  
  This module provides the 'importLib' templateHaskell function to import a
  C-library easily.
  
  To use this, set the __LANGUAGE TemplateHaskell__ pragma in your module
  file and include this module.
  
  Usage:
  Use 'importLib' as top-level declaration in your file. Like: 
  
  @
  importLib "LibAlsa" "libasound.so" []
  @
  
  This will create a data type for the library, and a function to get a handle for
  this library (data <LibAlsa> and get<LibAlsa>).
  To call your functions use the record syntax on that handle.
  -}
  module Monky.Template
    ( importLib
    , module Foreign.Ptr
    )
  where
  
  import Control.Monad (liftM2)
  import Data.Char (isSpace)
  import Data.List (nub)
  import Foreign.Ptr (Ptr, FunPtr, castFunPtr)
  import Language.Haskell.TH
  import Monky.Utility
  import Data.Maybe (fromMaybe)
  import System.Posix.DynamicLinker (DL, dlclose, dlopen, dlsym, RTLDFlags(RTLD_LAZY))
  
  #if MIN_VERSION_base(4,8,0)
  #else
  import Control.Applicative ((<$>))
  #endif
  
  #if MIN_VERSION_base(4,9,0)
  monkyStrict :: Bang
  monkyStrict = Bang NoSourceUnpackedness NoSourceStrictness
  #else
  monkyStrict :: Strict
  monkyStrict = NotStrict
  #endif
  
  -- trim a string
  ltrim :: String -> String
  ltrim = dropWhile isSpace
  
  rtrim :: String -> String
  rtrim = reverse . ltrim . reverse
  
  trim :: String -> String
  trim = rtrim . ltrim
  
  -- Split type string
  prepareFun :: String -> [String]
  prepareFun = map trim . splitAtEvery "->" . trim
  
  -- get constructor name
  getName :: String -> Q Name
  getName name =
    fromMaybe (error $ "Could not find constructor: " ++ name) <$> lookupTypeName name
  
  -- Get a type from a String, this can do ONE application, so IO works
  getType :: String -> Q Type
  getType xs = if ' ' `elem` xs
    then let [t,a] = words xs in
      liftM2 AppT (getT t) (getT a)
    else getT xs
    where getT "()" = return (TupleT 0)
          getT ys = ConT <$> getName ys
  
  
  -- Apply arrows to create a function from types
  applyArrows :: [Type] -> Type
  applyArrows [] = error "Cannot work with empty function type"
  applyArrows [x] = x
  applyArrows (x:xs) = AppT (AppT ArrowT x) (applyArrows xs)
  
  
  -- Create function declarations for the constructor
  mkFunDesc :: (String, String) -> VarStrictTypeQ
  mkFunDesc (x,y) = do
    t <- applyArrows <$> mapM getType (prepareFun y)
    return (mkName x, monkyStrict, t)
  
  
  cleanName :: Char -> String
  cleanName '(' = "vo"
  cleanName ')' = "id"
  cleanName  x  = return x
  
  
  -- Get the transformer name, this is some ugly name mangeling
  transName :: String -> String
  transName = concatMap cleanName . ("mkFun" ++) . filter isOk
    where isOk c = not (isSpace c) && c /= '-' && c /= '>'
  
  
  -- Get the function described by the three-tuple (Alias, C-Name, TypeString)
  getFunQ :: Name -> (String, String, String) -> Q Stmt
  getFunQ handle (alias, name, typeString) = do
    let castFPtr = [| $(varE . mkName $ transName typeString) . castFunPtr |]
    let getSym = [| dlsym $(varE handle) name |]
    BindS (VarP (mkName (alias ++ "_"))) <$> [| fmap $(castFPtr) $(getSym) |]
  
  
  -- Create the return statement, this applies the constructor
  mkRet :: Name -> [String] -> Name -> Exp -> Q Stmt
  mkRet hname xs rawN raw= do
    let funs = map (\x -> return (mkName x, VarE (mkName (x ++ "_")))) xs
    let con = recConE hname (return (rawN,raw):funs)
    NoBindS <$> [| return $(con) |]
  
  
  -- Create the statement to get the handle
  mkGetHandle :: Name -> String -> Q Stmt
  mkGetHandle h libname =
    BindS (VarP h) <$> [| dlopen libname [RTLD_LAZY] |]
  
  
  -- Create the get<LibName> function
  mkGetFun :: String -> String -> Name -> [(String, String, String)] -> Name -> Q [Dec]
  mkGetFun lname name hname funs raw = do
    let funName = mkName ("get" ++ name)
    let handle = mkName "handle"
    ghandle <- mkGetHandle handle lname
    funStmts <- mapM (getFunQ handle) funs
    ret <- mkRet hname (map (\(x,_,_) -> x) funs) raw (VarE handle)
    let fun = FunD funName [Clause [] (NormalB $ DoE Nothing (ghandle:funStmts ++ [ret])) []]
    sig <- sigD funName [t| IO $(conT . mkName $ name) |]
    return [sig,fun]
  
  
  -- Create the transformer function used by get<LibName>
  mkTransformer :: String -> Q Dec
  mkTransformer f = do
    let name = mkName . transName $ f
    let ty = applyArrows <$> mapM getType (prepareFun f)
    ForeignD . ImportF CCall Safe "dynamic" name <$>  [t| (FunPtr $(ty)) -> $(ty) |]
  
  
  mkDestroyFun :: String -> Name -> Q [Dec]
  mkDestroyFun name raw = do
    let libT = mkName name
    let hname = mkName "handle"
    let funName = mkName ("destroy" ++ name)
    let body = [| dlclose ($(varE raw) $(varE hname)) |]
  
    sig <- sigD funName [t| $(conT libT) -> IO () |]
    fun <- funD funName [clause [varP hname] (normalB body) []]
    return [sig ,fun]
  
  -- |Import a library
  importLib
    :: String -- ^The name of the library data type
    -> String -- ^The name of the library
    -> [(String, String, String)] -- ^The functions in the library (Name, CName, Declaration)
    -> Q [Dec]
  importLib hname lname xs = do
    let name = mkName hname
    funs <- mapM (mkFunDesc . (\(x,_,y) -> (x,y))) xs
    transformers <- mapM mkTransformer $ nub $ map (\(_,_,x) -> x) xs
    let rawRN = mkName "rawDL"
    let raw = (rawRN, monkyStrict, ConT ''DL)
  #if MIN_VERSION_base(4,9,0)
    let dhandle = DataD [] name [] Nothing [RecC (mkName hname) (raw:funs)] []
  #else
    let dhandle = DataD [] name []         [RecC (mkName hname) (raw:funs)] []
  #endif
    fun <- mkGetFun lname hname name xs rawRN
    dest <- mkDestroyFun hname rawRN
    return (dhandle:dest ++ transformers ++ fun)
  