{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module Data.Comp.Derive.HaskellStrict
(
makeHaskellStrict
, haskellStrict
, haskellStrict'
) where
import Control.Monad hiding (mapM, sequence)
import Data.Comp.Derive.Utils
import Data.Comp.Sum
import Data.Comp.Thunk
import Data.Foldable hiding (any, or)
import Data.Maybe
import Data.Traversable
import Language.Haskell.TH
import Prelude hiding (foldl, foldr, mapM, sequence)
import qualified Prelude as P (all, foldl, foldr, mapM)
class HaskellStrict f where
thunkSequence :: (Monad m) => f (TermT m g) -> m (f (TermT m g))
thunkSequenceInject :: (Monad m, f :<: m :+: g) => f (TermT m g) -> TermT m g
thunkSequenceInject t = thunk $ liftM inject $ thunkSequence t
thunkSequenceInject' :: (Monad m, f :<: m :+: g) => f (TermT m g) -> TermT m g
thunkSequenceInject' = thunkSequenceInject
haskellStrict :: (Monad m, HaskellStrict f, f :<: m :+: g) => f (TermT m g) -> TermT m g
haskellStrict = thunkSequenceInject
haskellStrict' :: (Monad m, HaskellStrict f, f :<: m :+: g) => f (TermT m g) -> TermT m g
haskellStrict' = thunkSequenceInject'
deepThunk d = iter d [|thunkSequence|]
where iter 0 _ = [|whnf'|]
iter 1 e = e
iter n e = iter (n-1) ([|mapM|] `appE` e)
makeHaskellStrict :: Name -> Q [Dec]
makeHaskellStrict fname = do
Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
let fArg = VarT . tyVarBndrName $ last args
argNames = map (VarT . tyVarBndrName) (init args)
complType = foldl AppT (ConT name) argNames
classType = AppT (ConT ''HaskellStrict) complType
constrs_ <- P.mapM (liftM (isFarg fArg) . normalConStrExp) constrs
if foldr (\ y x -> x && P.all null (snd y)) True constrs_
then do
sequenceDecl <- valD (varP 'thunkSequence) (normalB [|return|]) []
injectDecl <- valD (varP 'thunkSequenceInject) (normalB [|inject|]) []
injectDecl' <- valD (varP 'thunkSequenceInject') (normalB [|inject|]) []
return [mkInstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]
else do
(sc',matchPat,ic') <- liftM unzip3 $ P.mapM mkClauses constrs_
xn <- newName "x"
doThunk <- [|thunk|]
let sequenceDecl = FunD 'thunkSequence sc'
injectDecl = FunD 'thunkSequenceInject [Clause [VarP xn] (NormalB (doThunk `AppE` CaseE (VarE xn) matchPat)) []]
injectDecl' = FunD 'thunkSequenceInject' ic'
return [mkInstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]
where isFarg fArg (constr, args, gadtTy) = (constr, map (containsStr (getUnaryFArg fArg gadtTy)) args)
#if __GLASGOW_HASKELL__ < 800
containsStr fArg (IsStrict,ty) = ty `containsType'` fArg
containsStr fArg (Unpacked,ty) = ty `containsType'` fArg
#else
containsStr fArg (Bang _ SourceStrict,ty) = ty `containsType'` fArg
containsStr fArg (Bang SourceUnpack _,ty) = ty `containsType'` fArg
#endif
containsStr _ _ = []
filterVar _ nonFarg [] x = nonFarg x
filterVar farg _ [depth] x = farg depth x
filterVar _ _ _ _ = error "functor variable occurring twice in argument type"
filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs
mkCPat constr varNs = ConP constr $ map mkPat varNs
mkPat = VarP
mkClauses (constr, args) =
do varNs <- newNames (length args) "x"
let pat = mkCPat constr varNs
fvars = catMaybes $ filterVars args varNs (curry Just) (const Nothing)
allVars = map varE varNs
conAp = P.foldl appE (conE constr) allVars
conBind (d, x) y = [| $(deepThunk d `appE` varE x) >>= $(lamE [varP x] y)|]
bodySC' <- P.foldr conBind [|return $conAp|] fvars
let sc' = Clause [pat] (NormalB bodySC') []
bodyMatch <- case fvars of
[] -> [|return (inject $conAp)|]
_ -> P.foldr conBind [|return (inject $conAp)|] fvars
let matchPat = Match pat (NormalB bodyMatch) []
bodyIC' <- case fvars of
[] -> [|inject $conAp|]
_ -> [| thunk |] `appE` P.foldr conBind [|return (inject $conAp)|] fvars
let ic' = Clause [pat] (NormalB bodyIC') []
return (sc', matchPat, ic')