Foreign.Storable.TH

TH.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
-- |

module Foreign.Storable.TH where

import Foreign.Storable
import Foreign.Ptr
import Language.Haskell.TH
import Present

-- | Make a storable instance for a type.
makeStorable :: Name -> Q [Dec]
makeStorable name = do
    mtypeDefinition <- reifyTypeDefinition (TypeConstructor name)
    case mtypeDefinition of
      Nothing -> fail "No such regular type."
      Just typeDefinition ->
          case typeDefinition of
            TypeAliasDefinition{} ->
                fail "Don't support making Storable for type-aliases. Use the proper type."
            DataTypeDefinition _ (DataType _ [Constructor (ValueConstructor cname) fields]) ->
                [d|instance Storable $(conT name) where
                     sizeOf o =
                         $(mapM
                               (\(mv,_) ->
                                    case mv of
                                      Nothing -> fail "Only record types supported for Storable."
                                      Just (ValueVariable fname) ->
                                          return
                                              [|sizeOf
                                                    (asTypeOf undefined
                                                              ($(varE fname) o))|])
                               fields >>=
                           foldl (\a b -> infixE (Just a) (varE '(+)) (Just b)) [|0|])
                     alignment o = $(mapM
                                         (\(mv,_) ->
                                              case mv of
                                                Nothing -> fail "Only record types supported for Storable."
                                                Just (ValueVariable fname) ->
                                                    return
                                                        [|sizeOf
                                                              (asTypeOf undefined
                                                                        ($(varE fname) o))|])
                                         fields >>=
                                     foldl (\a b -> infixE (Just a) (varE 'max) (Just b)) [|0|])
                     peek ptr =
                         $(let binds =
                                   fst
                                       (foldl
                                            (\(stmts,aggregate) (i,_) ->
                                                 let stmt =
                                                         bindS (varP (mkFname i))
                                                               [|peek (plusPtr ptr $(aggregate))|]
                                                 in (stmt : stmts
                                                     ,[|$(aggregate) +
                                                        sizeOf $(varE (mkFname i))|]))
                                            ([],[|0|])
                                            (zip [0 :: Int ..] fields))
                               returnStmt =
                                   [|return
                                         $(foldl (\e (i,_) ->
                                                      appE e (varE (mkFname i)))
                                                 (conE cname)
                                                 (zip [0 :: Int ..] fields))|]
                           in doE (reverse binds ++
                                   [noBindS returnStmt]))
                     poke ptr =
                         $(lamCaseE
                               [match
                                     (conP cname
                                           (map (\(i,_) -> varP (mkFname i))
                                                (zip [0 :: Int ..] fields)))
                                     (normalB (let exps =
                                                     fst
                                                         (foldl
                                                              (\(stmts,aggregate) (i,_) ->
                                                                   let stmt =
                                                                           [|poke (plusPtr ptr $(aggregate)) $(varE (mkFname i))|]
                                                                   in (stmt : stmts
                                                                       ,[|$(aggregate) +
                                                                          sizeOf $(varE (mkFname i))|]))
                                                              ([],[|0|])
                                                              (zip [0 :: Int ..] fields))
                                               in doE (map noBindS exps)))
                                     []])
                     |]
              where mkFname (i :: Int) = mkName ("f" ++ show i)
            _ -> fail "Don't support multiple-constructor data types for Storable at the moment."