{-# OPTIONS -fglasgow-exts #-}
-- |FreeType - binding to FreeType font rendering library
-- <http://www.freetype.org/freetype2/>

module FreeType where

-- JAS - how do we do error handling -- exceptions vs Either

import Control.Exception
import Data.Bits
import Data.Char
import Data.Int
import Data.Word
import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import Prelude hiding (catch)

#include <ft2build.h>
#include FT_FREETYPE_H       

type FT_Long = #{type FT_Long}
type FT_ULong = #{type FT_ULong}
type FT_UInt = #{type FT_UInt}
type FT_Int32 = #{type FT_Int32}

data FT_LibraryRec
type FT_Library = Ptr FT_LibraryRec
type FT_Error = #{type FT_Error}

foreign import ccall unsafe "FT_Init_FreeType" c_FT_Init_FreeType :: Ptr FT_Library -> IO FT_Error
foreign import ccall unsafe "FT_Done_FreeType" c_FT_Done_FreeType :: FT_Library -> IO FT_Error

-- JAS - does allocaBytes use bracket ?
-- JAS - catch done errors
withFreeType :: (FT_Library -> IO a) -> IO (Either (FT_Error, Maybe a) a)
withFreeType action =
    allocaBytes #{size FT_Library} $ \ptr ->
        do ret <- c_FT_Init_FreeType ptr
           if ret == 0
             then do actionResult <- (peek ptr >>= action) `catch` (\e -> peek ptr >>= c_FT_Done_FreeType >> throwIO e)
                     ret <- peek ptr >>= c_FT_Done_FreeType
                     if ret == 0
                        then return (Right actionResult)
                        else return (Left (ret, Just actionResult))
             else return (Left (ret,Nothing))

-- * FT_Face

data FT_FaceRec
type FT_Face = Ptr FT_FaceRec

foreign import ccall unsafe "FT_New_Face" c_FT_New_Face :: FT_Library -> CString -> FT_Long -> Ptr FT_Face -> IO FT_Error
foreign import ccall unsafe "FT_Done_Face" c_FT_Done_Face :: FT_Face -> IO FT_Error

withNewFace :: FT_Library -> FilePath -> FT_Long -> ((FT_Face -> IO a) -> IO (Either (FT_Error, Maybe a) a))
withNewFace ftLibrary filePath faceIndex action =
    do allocaBytes #{size FT_Face} $ \ ftFacePtr ->
           withCString filePath $ \ fp ->
               do ret <- c_FT_New_Face ftLibrary fp faceIndex ftFacePtr
                  if ret == 0
                    then do actionResult <- (peek ftFacePtr >>= action) `catch` (\e -> peek ftFacePtr >>= c_FT_Done_Face >> throwIO e)
                            ret <- peek ftFacePtr >>= c_FT_Done_Face
                            if ret == 0
                              then return (Right actionResult)
                              else return (Left (ret, Just actionResult))
                    else return (Left (ret,Nothing))

faceFlags :: FT_Face -> IO #{type FT_Long}
faceFlags face = #{peek FT_FaceRec, face_flags} face

faceFlagKerning :: #{type FT_Long}
faceFlagKerning = #{const FT_FACE_FLAG_KERNING }

-- * 

type FT_F26Dot6 = #{type FT_F26Dot6}

foreign import ccall unsafe "FT_Set_Char_Size" setCharSize :: FT_Face -> FT_F26Dot6 -> FT_F26Dot6 -> FT_UInt -> FT_UInt -> IO FT_Error
foreign import ccall unsafe "FT_Set_Pixel_Sizes" setPixelSizes :: FT_Face -> FT_UInt -> FT_UInt -> IO FT_Error
foreign import ccall unsafe "FT_Get_Char_Index" c_FT_Get_Char_Index :: FT_Face -> FT_ULong -> IO FT_UInt

getCharIndex :: FT_Face -> Char -> IO FT_UInt
getCharIndex ftFace c = c_FT_Get_Char_Index ftFace (fromIntegral (ord c))

data LoadFlag 
    = LoadDefault
    | LoadNoScale
    | LoadNoHinting
    | LoadRender
    | LoadNoBitmap
    | LoadVerticalLayout
    | LoadForceAutohint
    | LoadCropBitmap
    | LoadPedantic
    | LoadIgnoreGlobalAdvanceWidth
    | LoadNoRecurse
    | LoadIgnoreTransform
    | LoadMonochrome
    | LoadLinearDesign
      deriving Show

instance Enum LoadFlag where
    toEnum #{const FT_LOAD_DEFAULT} = LoadDefault
    toEnum #{const FT_LOAD_NO_SCALE} = LoadNoScale
    toEnum #{const FT_LOAD_NO_HINTING} = LoadNoHinting
    toEnum #{const FT_LOAD_RENDER} = LoadRender
    toEnum #{const FT_LOAD_NO_BITMAP} = LoadNoBitmap
    toEnum #{const FT_LOAD_VERTICAL_LAYOUT} = LoadVerticalLayout
    toEnum #{const FT_LOAD_FORCE_AUTOHINT} = LoadForceAutohint
    toEnum #{const FT_LOAD_CROP_BITMAP} = LoadCropBitmap
    toEnum #{const FT_LOAD_PEDANTIC} = LoadPedantic
    toEnum #{const FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH} = LoadIgnoreGlobalAdvanceWidth
    toEnum #{const FT_LOAD_NO_RECURSE} = LoadNoRecurse
    toEnum #{const FT_LOAD_IGNORE_TRANSFORM} = LoadIgnoreTransform
    toEnum #{const FT_LOAD_MONOCHROME} = LoadMonochrome
    toEnum #{const FT_LOAD_LINEAR_DESIGN} = LoadLinearDesign

    fromEnum LoadDefault = #{const FT_LOAD_DEFAULT}
    fromEnum LoadNoScale = #{const FT_LOAD_NO_SCALE}
    fromEnum LoadNoHinting = #{const FT_LOAD_NO_HINTING}
    fromEnum LoadRender = #{const FT_LOAD_RENDER}
    fromEnum LoadNoBitmap = #{const FT_LOAD_NO_BITMAP}
    fromEnum LoadVerticalLayout = #{const FT_LOAD_VERTICAL_LAYOUT}
    fromEnum LoadForceAutohint = #{const FT_LOAD_FORCE_AUTOHINT}
    fromEnum LoadCropBitmap = #{const FT_LOAD_CROP_BITMAP}
    fromEnum LoadPedantic = #{const FT_LOAD_PEDANTIC}
    fromEnum LoadIgnoreGlobalAdvanceWidth = #{const FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH}
    fromEnum LoadNoRecurse = #{const FT_LOAD_NO_RECURSE}
    fromEnum LoadIgnoreTransform = #{const FT_LOAD_IGNORE_TRANSFORM}
    fromEnum LoadMonochrome = #{const FT_LOAD_MONOCHROME}
    fromEnum LoadLinearDesign = #{const FT_LOAD_LINEAR_DESIGN}
              

foreign import ccall unsafe "FT_Load_Glyph" c_FT_Load_Glyph :: FT_Face -> FT_UInt -> FT_Int32 -> IO FT_Error

loadGlyph :: FT_Face -> FT_UInt -> [LoadFlag] -> IO FT_Error
loadGlyph face glyphIndex flags = c_FT_Load_Glyph face glyphIndex (mkFlags flags)

mkFlags :: (Enum f, Num a) => [f] -> a
mkFlags flags = fromIntegral $ foldl (.|.) 0 (map fromEnum flags)

-- *  FT_GlyphSlot

data FT_GlyphSlotRec
type FT_GlyphSlot = Ptr FT_GlyphSlotRec

advance :: FT_GlyphSlot -> IO FT_Vector
advance = ftVector . #{ptr FT_GlyphSlotRec, advance}

glyph :: FT_Face -> IO FT_GlyphSlot
glyph = #{peek FT_FaceRec, glyph}

-- * FT_Bitmap

data FT_Bitmap

bitmap :: FT_GlyphSlot -> Ptr FT_Bitmap
bitmap = #{ptr FT_GlyphSlotRec, bitmap}

bitmap_left :: FT_GlyphSlot -> IO Int
bitmap_left = #{peek FT_GlyphSlotRec, bitmap_left}

bitmap_top :: FT_GlyphSlot -> IO Int
bitmap_top = #{peek FT_GlyphSlotRec, bitmap_top}

rows :: Ptr FT_Bitmap -> IO CInt
rows = #{peek FT_Bitmap, rows}

width :: Ptr FT_Bitmap -> IO CInt
width = #{peek FT_Bitmap, width}

pitch :: Ptr FT_Bitmap -> IO CInt
pitch = #{peek FT_Bitmap, pitch}

numGrays :: Ptr FT_Bitmap -> IO #{type short}
numGrays = #{peek FT_Bitmap, num_grays}

buffer :: Ptr FT_Bitmap -> IO (Ptr Word8)
buffer = #{peek FT_Bitmap, buffer}

-- * FT_Vector

newtype FT_Vector = FT_Vector ((#type FT_Pos), (#type FT_Pos))

ftVector :: Ptr FT_Vector -> IO FT_Vector
ftVector pFtVector = 
    do x <- #{peek FT_Vector, x} pFtVector
       y <- #{peek FT_Vector, y} pFtVector
       return $ FT_Vector (x, y)

-- * FT_Get_Kerning

foreign import ccall unsafe "FT_Get_Kerning" c_FT_Get_Kerning :: FT_Face -> #{type FT_UInt} -> #{type FT_UInt} -> #{type FT_UInt} -> Ptr FT_Vector -> IO FT_Error

data KerningMode 
    = KerningDefault
    | KerningUnfitted
    | KerningUnscaled
      deriving Show

getKerning :: FT_Face -- face
           -> #{type FT_UInt} -- left_glyph index
           -> #{type FT_UInt} -- right_glyph index
           -> KerningMode
           -> IO (Either FT_Error FT_Vector)
getKerning face leftIndex rightIndex kerningMode =
    allocaBytes #{size FT_Vector} $ \ (akerning :: (Ptr FT_Vector)) ->
        do ret <- c_FT_Get_Kerning face leftIndex rightIndex (cKerningMode kerningMode) akerning
           case ret of
             0 -> ftVector akerning >>= return . Right
             n -> return (Left n)
    where
      cKerningMode KerningDefault  = #{const FT_KERNING_DEFAULT}
      cKerningMode KerningUnfitted = #{const FT_KERNING_UNFITTED}
      cKerningMode KerningUnscaled = #{const FT_KERNING_UNSCALED}

{-
    = FT_Bitmap { bmRows :: #{type int}
                , bmWidth :: #{type int}
                , bmPitch :: #{type int}
                , bmBuffer :: Ptr Word8
                , bmNumGrays :: #{type short}
                , bmPixelMode :: #{type char}
                , bmPaletteMode :: #{type char}
                , pall
                }
-}


{-
Error handling:

 ~ Almost all the freetype functions return an error code

 ~ a few functions have new/delete type semantics that we want to wrap
   into a single function

 ~ If an error is encountered in the inner with, we may also encounter
   more errors when passing the error back up.

 ~ The error may not occur until after we have evaluated the action --
   so we may actually have a useful result if only the 'delete'
   functions fail.

 ~ if the action throws an exception, we still want to do the cleanup (aka, finally)

 ~ if we fail before the action, we may not have a result to return

 ~ if we don't get a result from action, then we definately had an error

 ~ so we have three return cases:
    + no error
    + error before action 
    + error after action
-}
{-
data Result a e
    = NoError a
    | NoResult e
    | ErrorWithResult a e
      deriving Show
-}



-- foreign import ccall "FT_Get_Char_Index" c_FT_Get_Char_Index ::