module Control.Plumbers.Specs where
import Control.Plumbers.TH
import Language.Haskell.TH
#if MIN_VERSION_template_haskell(2,10,0)
(Exp(TupE), Type(AppT, ForallT, ConT), mkName)
#else
(Exp(TupE), Type(AppT, ForallT), Pred(ClassP), mkName)
#endif
productSpec :: PlumberSpec
productSpec = (baseSpec "*" "_") { plumberTypes = Just productTypes
, plumberOpE = (\l r -> TupE [l, r]) }
compositionSpec :: PlumberSpec
compositionSpec = (baseSpec "$" "$") { plumberTypes = Just compositionTypes }
lbindSpec :: PlumberSpec
lbindSpec = (baseSpec "<=" "=<<") { plumberTypes = Just lbindTypes }
rbindSpec :: PlumberSpec
rbindSpec = (baseSpec ">=" ">>=") { plumberTypes = Just rbindTypes }
frbindSpec :: PlumberSpec
frbindSpec = (baseSpec ">>" ">>") { plumberTypes = Just $ fbindTypes False }
flbindSpec :: PlumberSpec
flbindSpec = (baseSpec "<<" "<<") { plumberTypes = Just $ fbindTypes True }
productTypes :: PlumberTypes
productTypes = addBaseContext $ baseTypes
{ resultType = tuplesT [leftType baseTypes, rightType baseTypes] }
compositionTypes :: PlumberTypes
compositionTypes = addBaseContext $ baseTypes
{ leftType = arrowsT [rightType baseTypes, leftType baseTypes]
, resultType = leftType baseTypes
}
lbindTypes :: PlumberTypes
lbindTypes = addBaseContext . addMonadContext $ baseTypes
{ leftType = arrowsT [rightType baseTypes, result]
, rightType = AppT m $ rightType baseTypes
, resultType = result
}
where
m = mkVT "m"
result = AppT m $ leftType baseTypes
rbindTypes :: PlumberTypes
rbindTypes = baseTypes
{ leftType = rightType lbindTypes
, rightType = leftType lbindTypes
, resultType = resultType lbindTypes
}
fbindTypes :: Bool -> PlumberTypes
fbindTypes b = addMonadContext . addBaseContext $ baseTypes
{ leftType = AppT m $ leftType baseTypes
, rightType = AppT m $ rightType baseTypes
, resultType = AppT m $ (if b then leftType else rightType) baseTypes
}
where
m = mkVT "m"
addMonadContext x = x { resultType = addForalls mforall $ resultType x }
where
m = mkVT "m"
#if MIN_VERSION_template_haskell(2,10,0)
mforall = (ForallT [mkVB "m"] [AppT (ConT $ mkName "Monad") m] undefined)
#else
mforall = (ForallT [mkVB "m"] [ClassP (mkName "Monad") [m]] undefined)
#endif
addBaseContext x = x { resultType = addForalls (resultType baseTypes) $ resultType x }