module Control.Plumbers.TH
( PlumberSpec (..), baseSpec
, PlumberTypes(..), baseTypes
, implementPlumbers, implementPlumber
, operatorNames, aritiesString
, appsT, arrowsT, tuplesT
, mkVE, mkVP, mkVT, mkVB
, addForalls
) where
import Control.Applicative ((<$>))
import Data.Bits (testBit)
import Data.List (intersperse)
import Language.Haskell.TH
data PlumberTypes = PlumberTypes
{ leftType :: Type
, rightType :: Type
, resultType :: Type
}
baseTypes :: PlumberTypes
baseTypes = PlumberTypes
{ leftType = mkVT "r'"
, rightType = mkVT "r''"
, resultType = ForallT [mkVB "r'", mkVB "r''"] [] undefined
}
data PlumberSpec = PlumberSpec
{ plumberOpE :: Exp -> Exp -> Exp
, plumberTypes :: Maybe PlumberTypes
, plumberArities :: [Int]
, plumberPrefix :: String
}
baseSpec :: String -> String -> PlumberSpec
baseSpec p e = PlumberSpec
{ plumberOpE = (\l r -> InfixE (Just l) (mkVE e) (Just r))
, plumberTypes = Nothing
, plumberArities = [1..3]
, plumberPrefix = p
}
operatorNames :: PlumberSpec -> [[String]]
operatorNames s
= map (map (plumberPrefix s ++) . sequence . (`replicate` "^<>&*"))
$ plumberArities s
aritiesString :: PlumberSpec -> String
aritiesString
= unlines
. map (("infixr 9 "++) . concat . intersperse ", ")
. operatorNames
implementPlumbers :: PlumberSpec -> DecsQ
implementPlumbers spec
= concat <$> mapM (implementPlumber spec)
(concat $ operatorNames spec)
implementPlumber :: PlumberSpec -> String -> DecsQ
implementPlumber spec name
= return $ maybe [] ((:[]) . sig) (plumberTypes spec) ++ [func]
where
directives :: [(Int, Either String (String, String))]
directives = rec dirs (map (:[]) ['a'..'z'])
where
dirs = drop (length $ plumberPrefix spec) name
rec [] _ = []
rec ('^':xs) (y :ys) = (0, Left y) : rec xs ys
rec ('<':xs) (y :ys) = (1, Left y) : rec xs ys
rec ('>':xs) (y :ys) = (2, Left y) : rec xs ys
rec ('&':xs) (y :ys) = (3, Left y) : rec xs ys
rec ('*':xs) (y:z:ys) = (3, Right (y, z)) : rec xs ys
params = map snd directives
names = concatMap (either (:[]) (\(y, z) -> [y, z])) params
args1 = [either id fst x | (i, x) <- directives, testBit i 0]
args2 = [either id snd x | (i, x) <- directives, testBit i 1]
sig types
= SigD (mkName name)
. ForallT (map mkVB names ++ bs) ctx
. arrowsT
$ [ arrowsT $ map mkVT args1 ++ [leftType types]
, arrowsT $ map mkVT args2 ++ [rightType types] ]
++ map mkTyp params
++ [rt]
where
(ForallT bs ctx rt) = resultType types
mkTyp (Right (a, b)) = tuplesT [mkVT a, mkVT b]
mkTyp (Left a) = mkVT a
func = FunD (mkName name) [Clause binds (NormalB body) []]
binds = map mkVP ["f1", "f2"] ++ map mkBind directives
mkBind (0, _) = WildP
mkBind (_, Left a) = mkVP a
mkBind (_, Right (a, b)) = TupP [mkVP a, mkVP b]
body = plumberOpE spec (mkF "f1" args1) (mkF "f2" args2)
mkF n = foldl1 AppE . (mkVE n:) . map mkVE
appsT, arrowsT, tuplesT :: [Type] -> Type
appsT = foldl1 AppT
arrowsT = foldr1 (\x y -> appsT [ArrowT, x, y])
tuplesT xs = appsT $ [TupleT $ length xs] ++ xs
mkVE :: String -> Exp
mkVE = VarE . mkName
mkVP :: String -> Pat
mkVP = VarP . mkName
mkVT :: String -> Type
mkVT = VarT . mkName
mkVB :: String -> TyVarBndr
mkVB = PlainTV . mkName
addForalls :: Type -> Type -> Type
addForalls (ForallT b c _) (ForallT b' c' t) = ForallT (b ++ b') (c ++ c') t
addForalls (ForallT b c _) x = ForallT b c x