{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Control.Static.TH
( staticRef
, staticKey
, staticKeyType
, mkStatics
, mkStaticsWithRefs
, defaultStaticTab
, mkDefStaticTab
, mkStaticTab
, CxtW(..)
)
where
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Data.Functor (($>))
import Data.List (unzip5)
import Data.Singletons (sing)
import GHC.IO.Unsafe (unsafeDupableInterleaveIO)
import Language.Haskell.TH
import Control.Static.Common (CxtW (..), TCTab (..), TTab)
import Control.Static.Static (SKeyed (..), skeyedCons)
mfixQ :: (b -> Q b) -> Q b
mfixQ k = do
m <- runIO newEmptyMVar
ans <- runIO (unsafeDupableInterleaveIO (takeMVar m))
result <- k ans
runIO (putMVar m result)
pure result
mkStatics :: [Name] -> Q [Dec]
mkStatics ns = mapM getType ns >>= createStatics Nothing
mkStaticsWithRefs :: ([Exp] -> Q [Dec]) -> Q [Dec]
mkStaticsWithRefs mkDecs = do
statics <- mfixQ f
decls <- mkDecs statics
closures <- createStatics Nothing (sigsOf decls)
pure $ decls <> closures
where
f :: ([Exp] -> Q [Exp])
f statics = do
decls <- mkDecs statics
traverse (staticRef . fst) (sigsOf decls)
defaultStaticTab :: Name
defaultStaticTab = mkName "staticTab"
mkDefStaticTab :: [Name] -> Q [Dec]
mkDefStaticTab = mkStaticTab defaultStaticTab
mkStaticTab :: Name -> [Name] -> Q [Dec]
mkStaticTab tabName ns = mapM getType ns >>= createStatics (Just tabName)
staticRef :: Name -> Q Exp
staticRef = varE . staticName
staticKey :: Name -> Q Exp
staticKey name = [| sing @ $(symFQN name) |]
staticKeyType :: Name -> Q Type
staticKeyType = symFQN
createStatics :: Maybe Name -> [(Name, Type)] -> Q [Dec]
createStatics tabName sigs = do
(closures, tyVars, keys, vals, inserts) <- unzip5 <$> mapM genStaticDefs sigs
staticTab <- maybe (pure [])
(\n -> genStaticTab n (concat tyVars) keys vals inserts)
tabName
pure $ concat closures <> staticTab
genStaticTab :: Name -> [TyVarBndr] -> [Q Type] -> [Q Type] -> [Q Exp] -> Q [Dec]
genStaticTab name tyVars keys vals is = sequence
[ sigD name $ do
ForallT tyVars [] <$> [t| TTab $(tyList keys) $(tyList vals) |]
, sfnD name $ apList is [| TCNil |]
]
genStaticDefs :: (Name, Type) -> Q ([Dec], [TyVarBndr], Q Type, Q Type, Q Exp)
genStaticDefs (fullName, fullType) = do
tyTval <- [t| SKeyed |]
tyCxtw <- [t| CxtW |]
let (tyVars', tyCxt', typ') = case fullType of
ForallT vars cxt' mono -> (vars, cxt', mono)
_ -> ([], [], fullType)
let tyCxt1 = cxtToType tyCxt'
let cxtVal mk n = appE (conE 'CxtW) (mk n)
(maybeCxt, maybeCxtTy) = case tyCxt' of
[] -> (id, pure)
_ -> (cxtVal, \typ -> pure (tyCxtw `AppT` tyCxt1 `AppT` typ))
let
fixVal mk n = appE (mk n) (staticRef n)
(maybeFix, tyVars, typ) = case typ' of
ArrowT `AppT` (t `AppT` (VarT sym) `AppT` (c `AppT` cxt' `AppT` typ_)) `AppT` typX
| t == tyTval && c == tyCxtw && cxt' == tyCxt1 && typ_ == typX
-> (fixVal, filter (\v -> tyVarName v /= sym) tyVars', typX)
ArrowT `AppT` (tyTval' `AppT` (VarT sym) `AppT` typ_) `AppT` typX
| tyTval' == tyTval && typ_ == typX
-> (fixVal, filter (\v -> tyVarName v /= sym) tyVars', typX)
_ -> (id, tyVars', typ')
let mkVal = maybeCxt (maybeFix varE)
let tyK = symFQN fullName
let tyV = maybeCxtTy typ
let name = staticName fullName
static <- flip recover (reify name $> []) $ sequence
[ sigD name $ ForallT tyVars [] <$> [t| SKeyed $(tyK) $(tyV) |]
, sfnD name [| SKeyed sing $(mkVal fullName) |]
]
pure (static, tyVars, tyK, tyV, [| skeyedCons $(staticRef fullName) |])
staticName :: Name -> Name
staticName n = mkName $ nameBase n ++ "__static"
apList :: [Q Exp] -> Q Exp -> Q Exp
apList [] base = base
apList (e : es) base = [| $e $ $(apList es base) |]
tyList :: [Q Type] -> Q Type
tyList [] = promotedNilT
tyList (h : tl) = do
ty <- h
(PromotedConsT `AppT` ty `AppT`) <$> tyList tl
cxtToType :: Cxt -> Type
cxtToType cxt' = case cxt' of
[] -> TupleT 0
[t] -> t
_ -> go (TupleT (length cxt')) cxt' where
go part [] = part
go part (h : tl) = go (part `AppT` h) tl
getType :: Name -> Q (Name, Type)
getType name = do
info <- reify name
case info of
VarI origName typ _ -> pure (origName, typ)
_ -> fail $ show name ++ " not a type: " ++ show info
sigsOf :: [Dec] -> [(Name, Type)]
sigsOf [] = []
sigsOf (SigD n t : tl) = (n, simplifyType t) : sigsOf tl
sigsOf (_ : tl) = sigsOf tl
simplifyType :: Type -> Type
simplifyType (ForallT t0 c0 (ForallT t1 c1 t)) =
simplifyType (ForallT (t0 <> t1) (c0 <> c1) t)
simplifyType t = t
sfnD :: Name -> Q Exp -> Q Dec
sfnD n e = funD n [clause [] (normalB e) []]
tyVarName :: TyVarBndr -> Name
tyVarName (PlainTV n ) = n
tyVarName (KindedTV n _) = n
symFQN :: Name -> Q Type
symFQN n = do
loc <- location
pure $ LitT $ StrTyLit $ loc_module loc ++ "." ++ nameBase n