content: module Foreign.HaPy (
      initHaPy,
      pythonExport,
      __exportInfo,
      module Foreign.C
  ) where
  
  import Foreign.HaPy.Internal ( peekList, copyList )
  import Language.Haskell.TH
  import Language.Haskell.TH.Syntax ( Lift(lift) )
  import Language.Haskell.TH.Lift ( deriveLift )
  
  import Foreign.C
      ( CInt(..),
        CDouble(..),
        CChar(..),
        castCharToCChar,
        castCCharToChar )
  import Foreign.Ptr ( Ptr )
  import Foreign.Marshal.Array ()
  import Foreign.Marshal.Alloc ( free )
  
  import Data.List ( intercalate )
  import Control.Monad ( zipWithM, replicateM, ap )
  
  data FType = FBool | FChar | FInt | FDouble | FList FType | FUnknown
    deriving (Eq, Ord, Show)
  
  deriveLift ''FType
  
  __exportInfo :: [FType] -> IO (Ptr [CChar])
  __exportInfo ftypes = copyList $ map castCharToCChar typeString
    where typeString = intercalate ";" $ map toTypeString ftypes
          toTypeString (FList t) = "List " ++ toTypeString t
          toTypeString FBool     = "Bool"
          toTypeString FChar     = "Char"
          toTypeString FInt      = "Int"
          toTypeString FDouble   = "Double"
          toTypeString _         = "Unknown"
  
  
  -- Can't use e.g. ''Bool when pattern matching
  fromHaskellType :: Type -> FType
  fromHaskellType (ConT nm) | nm == ''Bool   = FBool
                            | nm == ''Char   = FChar
                            | nm == ''Int    = FInt
                            | nm == ''Double = FDouble
                            | nm == ''String = FList FChar
  fromHaskellType (AppT ListT t) = FList (fromHaskellType t)
  fromHaskellType _ = FUnknown
  
  toForeignType :: FType -> Bool -> TypeQ
  toForeignType t ret | ret       = [t| IO $(toF t) |]
                      | otherwise = toF t
    where toF FBool     = [t| Bool |]
          toF FChar     = [t| CChar |]
          toF FInt      = [t| CInt |]
          toF FDouble   = [t| CDouble |]
          toF (FList t) = [t| Ptr [$(toF t)] |]
          toF _         = error "unknown type - cannot convert!" -- TODO: catch error at an earlier stage
  
  
  -- Converts the type of a function to a list of the type of its args and return value
  toTypeList :: Type -> [Type]
  toTypeList (AppT (AppT ArrowT t) ts) = t : toTypeList ts
  toTypeList t                         = [t]
  
  -- Converts the a list of the types of a function's args and return value to the type of a function
  fromTypeList :: [Type] -> Type
  fromTypeList []     = error "type list empty!"
  fromTypeList (t:[]) = t
  fromTypeList (t:ts) = (AppT (AppT ArrowT t) (fromTypeList ts))
  
  
  fromForeignExp :: FType -> ExpQ -> ExpQ
  fromForeignExp FBool     exp = [| return $ $exp |]
  fromForeignExp FChar     exp = [| return $ castCCharToChar $exp |]
  fromForeignExp FInt      exp = [| return $ fromIntegral $exp |]
  fromForeignExp FDouble   exp = [| return $ realToFrac $exp |]
  fromForeignExp (FList t) exp = [| peekList $exp >>= mapM (\x -> $(fromForeignExp t [|x|])) |]
  fromForeignExp _         exp = fail "conversion failed: unknown type!"
  
  toForeignExp :: FType -> ExpQ -> ExpQ
  toForeignExp FBool     exp = [| return $ $exp |]
  toForeignExp FChar     exp = [| return $ castCharToCChar $exp |]
  toForeignExp FInt      exp = [| return $ fromIntegral $exp |]
  toForeignExp FDouble   exp = [| return $ realToFrac $exp |]
  toForeignExp (FList t) exp = [| mapM (\x -> $(toForeignExp t [|x|])) $exp >>= copyList |]
  toForeignExp _         exp = fail "conversion failed: unknown type!"
  
  makeFunction :: (String -> String) -> (Name -> [FType] -> ClauseQ) -> ([FType] -> TypeQ) -> Name -> DecsQ
  makeFunction changeName makeClause makeType origName = do
    VarI _ t _ _ <- reify origName
    let types = map fromHaskellType $ toTypeList t
        name = mkName . changeName . nameBase $  origName
        cl   = makeClause origName types
        func = funD name [cl]
  
        typ  = makeType types
        dec = ForeignD `fmap` ExportF CCall (nameBase name) name `fmap` typ
    sequence [func, dec]
  
  makeInfoFunction :: Name -> DecsQ
  makeInfoFunction name = makeFunction makeName makeClause (const [t| IO (Ptr [CChar]) |]) name
      where makeName = (++ "__info")
            makeClause _ types = let body = normalB $ [| __exportInfo $(lift types) |] in
                                  clause [] body []
  
  
  makeExportFunction :: Name -> DecsQ
  makeExportFunction = makeFunction makeName makeClause makeType
      where makeName = (++ "__export")
            makeType ts = fmap fromTypeList $ zipWithM toForeignType ts (replicate (length ts - 1) False ++ [True])
            makeClause nm types = do
                vars <- replicateM (length types - 1) (newName "x")
                let args = map varP vars
                    convertedArgs = zipWith fromForeignExp types (map varE vars)
                    appliedFunction = foldl apArg [|return $(varE nm)|] convertedArgs
                    body = normalB $ [| $appliedFunction >>= \x -> $(toForeignExp (last types) [|x|]) |]
                clause args body []
            apArg :: ExpQ -> ExpQ -> ExpQ
            apArg f arg = [| ap $f $arg |]
  
  pythonExport :: Name -> DecsQ
  pythonExport nm = do
    info <- makeInfoFunction nm
    export <- makeExportFunction nm
    return $ info ++ export
  
  initHaPy :: DecsQ
  initHaPy = do
    exportType <- [t| Ptr () -> IO () |]
    let export = ForeignD $ ExportF CCall "__free" (mkName "__free") exportType
    func <- [d| __free = free |]
    return $ export:func
  