module System.Plugins.MultiStage
(
loadFunWithConfig
, loadFunType
, Config(..)
, defaultConfig
, CallConv(..)
, buildType
, applyTF
, expandTF
, pack
, unpack
, Reference(..)
, Marshal(..)
)
where
import Language.Haskell.TH
import Language.Haskell.TH.ExpandSyns
import Data.Int
import Data.Word
import Data.Maybe (mapMaybe)
import Control.Applicative
import Foreign.Ptr
import Foreign.Marshal (new)
import Foreign.Marshal.Unsafe (unsafeLocalState)
import Foreign.Storable
data Config = Config { declWorker :: Config -> Name -> Name -> [Name] -> Type -> [DecQ]
, builder :: Config -> Name -> Q Body
, worker :: Name -> [Name] -> Q Body
, typeFromName :: Name -> Q Type
, mkHSig :: Type -> Q Type
, mkCSig :: Type -> Q Type
, prefix :: String
, wdir :: String
, opts :: [String]
, safety :: Safety
}
defaultConfig :: Config
defaultConfig = Config { declWorker = declareWorker
, builder = noBuilder
, worker = noWorker
, typeFromName = loadFunType
, mkHSig = return
, mkCSig = return
, prefix = "c_"
, wdir = "tmp"
, opts = []
, safety = unsafe
}
noBuilder :: Config -> Name -> Q Body
noBuilder _ _ = normalB [| return nullPtr |]
noWorker :: Name -> [Name] -> Q Body
noWorker fun as = normalB $ appsE $ map varE $ fun:as
loadFunWithConfig :: Config -> [Name] -> Q [Dec]
loadFunWithConfig conf@Config{..} names = fmap concat $ mapM go names
where
go name = do
typ <- typeFromName name
let base = nameBase name
let cname = mkName $ prefix ++ base
let wname = mkName $ prefix ++ base ++ "_worker"
let args = [mkName $ 'v' : show i | i <- [1..(arity typ)]]
sequence $ declWorker conf wname name args typ
++ declareWrapper cname wname args typ
arity :: Type -> Int
arity (AppT (AppT ArrowT _) r) = 1 + arity r
arity _ = 0
loadFunType :: Name -> Q Type
loadFunType name = do
info <- reify name
case info of
(VarI _ t _ _) -> return t
_ -> error $ unwords ["loadFun:",show (nameBase name)
,"is not a function:",show info]
declareWorker :: Config -> Name -> Name -> [Name] -> Type -> [DecQ]
declareWorker conf@Config{..} wname name as typ =
[ declareImport conf factory csig
, sigD bname $ appT [t|Ptr|] csig
, funD bname [clause [] (builder conf name) []]
, sigD rname csig
, funD rname [clause [] (normalB [|$(varE factory) $ castPtrToFunPtr $(varE bname)|]) []]
, sigD wname hsig
, funD wname [clause (map varP as) (worker rname as) []]
]
where
base = nameBase name
bname = mkName $ prefix ++ base ++ "_builder"
factory = mkName $ prefix ++ base ++ "_factory"
rname = mkName $ prefix ++ base ++ "_raw"
hsig = mkHSig typ
csig = mkCSig typ
declareWrapper :: Name -> Name -> [Name] -> Type -> [DecQ]
declareWrapper cname wname as typ =
[ sigD cname (return typ)
, funD cname [clause (map varP as) (wrapper wname as) [] ]
]
declareImport :: Config -> Name -> TypeQ -> DecQ
declareImport Config{..} name csig =
forImpD cCall safety "dynamic" name [t|FunPtr $(csig) -> $(csig)|]
wrapper :: Name -> [Name] -> Q Body
wrapper workername args = normalB
[|unsafeLocalState $(appsE $ map varE $ workername : args) |]
data CallConv = CallConv { arg :: Type -> Q Type
, res :: Type -> Q Type
}
buildType :: CallConv -> Type -> Q Type
buildType CallConv{..} typ = go typ >>= expandTF
where
go (AppT (AppT ArrowT t) r) = arg t `arrT` go r
go r = res r
arrT t = appT (appT arrowT t)
applyTF :: Name -> Type -> Q Type
applyTF tf typ = appT (conT tf) $ expandSyns typ
expandTF :: Type -> Q Type
expandTF = down
where
down :: Type -> Q Type
down (AppT t1 t2) = appT (down t1) (down t2) >>= up
down t = up t
up :: Type -> Q Type
up t@(AppT (ConT fam) t1) = do
info <- reify fam
case info of
FamilyI{} -> do
is <- reifyInstances fam [t1]
case mapMaybe projInst is of
[(p1,pt2)]
| Just t2 <- substitute (matchP p1 t1) pt2
-> down t2
_ -> return t
_ -> return t
up t = return t
projInst :: Dec -> Maybe (Type, Type)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708
projInst (TySynInstD _ (TySynEqn [pattern] typ)) = Just (pattern,typ)
#else
projInst (TySynInstD _ [pattern] typ) = Just (pattern,typ)
#endif
projInst _ = Nothing
substitute :: [(Name,Type)] -> Type -> Maybe Type
substitute ss = go
where
go :: Type -> Maybe Type
go (VarT v) = lookup v ss
go (AppT a b) = AppT <$> go a <*> go b
go t = pure t
matchP :: Type -> Type -> [(Name,Type)]
matchP = go
where
go (VarT p1) t1 = [(p1,t1)]
go (AppT p1 p2) (AppT t1 t2) = go p1 t1 ++ go p2 t2
go p t = []
pack :: (Reference (Rep a), Marshal a) => a -> IO (Ref (Rep a))
pack a = to a >>= ref
unpack :: (Reference (Rep a), Marshal a) => Ref (Rep a) -> IO a
unpack a = deref a >>= from
class Reference a
where
type Ref a :: *
ref :: a -> IO (Ref a)
default ref :: (a ~ Ref a) => a -> IO (Ref a)
ref a = return a
deref :: Ref a -> IO a
default deref :: (a ~ Ref a) => Ref a -> IO a
deref a = return a
instance Reference Bool where type Ref Bool = Bool
instance Reference Int8 where type Ref Int8 = Int8
instance Reference Int16 where type Ref Int16 = Int16
instance Reference Int32 where type Ref Int32 = Int32
instance Reference Int64 where type Ref Int64 = Int64
instance Reference Word8 where type Ref Word8 = Word8
instance Reference Word16 where type Ref Word16 = Word16
instance Reference Word32 where type Ref Word32 = Word32
instance Reference Word64 where type Ref Word64 = Word64
instance Reference Float where type Ref Float = Float
instance Reference Double where type Ref Double = Double
class Marshal a
where
type Rep a :: *
to :: a -> IO (Rep a)
default to :: (a ~ Rep a) => a -> IO (Rep a)
to a = return a
from :: Rep a -> IO a
default from :: (a ~ Rep a) => Rep a -> IO a
from a = return a
instance Marshal Bool where type Rep Bool = Bool
instance Marshal Int8 where type Rep Int8 = Int8
instance Marshal Int16 where type Rep Int16 = Int16
instance Marshal Int32 where type Rep Int32 = Int32
instance Marshal Int64 where type Rep Int64 = Int64
instance Marshal Word8 where type Rep Word8 = Word8
instance Marshal Word16 where type Rep Word16 = Word16
instance Marshal Word32 where type Rep Word32 = Word32
instance Marshal Word64 where type Rep Word64 = Word64
instance Marshal Float where type Rep Float = Float
instance Marshal Double where type Rep Double = Double