MHTH used to consist of combinators which include quasi-quotes. They are moved from MagicHaskeller.lhs because Haddock dislikes quasi-quotes.
\begin{code}
{-# OPTIONS -XTemplateHaskell -cpp #-}
module MagicHaskeller.MHTH(expToExpExp, typeToExpType, decsToExpDecs) where
import Language.Haskell.TH hiding (plainTV)
import System.IO.Unsafe(unsafePerformIO)
import Data.IORef
import Control.Monad(liftM)
import Data.Maybe(fromJust)
import MagicHaskeller.ReadTHType(showTypeName, plainTV, unPlainTV)
#ifdef __GLASGOW_HASKELL__
nameToNameStr :: (Name -> String) -> Name -> ExpQ
nameToNameStr :: (Name -> String) -> Name -> ExpQ
nameToNameStr Name -> String
shw Name
name = Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ Lit -> Exp
LitE (String -> Lit
StringL (Name -> String
shw Name
name))
showName :: Name -> String
showName :: Name -> String
showName Name
name | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== '[] = String
"[]"
| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''[] = String
"[]"
| Bool
otherwise = Name -> String
forall a. Show a => a -> String
show Name
name
showVarName :: Name -> String
showVarName = Name -> String
showName
expToExpExp :: Exp -> ExpQ
expToExpExp :: Exp -> ExpQ
expToExpExp (VarE Name
name) = [| VarE (mkName $(nameToNameStr showVarName name)) |]
expToExpExp (ConE Name
name) = [| ConE (mkName $(nameToNameStr showVarName name)) |]
expToExpExp (AppE Exp
e0 Exp
e1) = [| AppE $(expToExpExp e0) $(expToExpExp e1) |]
expToExpExp (LamE [Pat]
ps Exp
e) = [| LamE $(liftM ListE $ mapM patToExpPat ps) $(expToExpExp e) |]
expToExpExp (InfixE Maybe Exp
Nothing Exp
e Maybe Exp
Nothing) = [| InfixE Nothing $(expToExpExp e) Nothing |]
expToExpExp (InfixE (Just Exp
e0) Exp
e Maybe Exp
Nothing) = [| InfixE (Just $(expToExpExp e0)) $(expToExpExp e) Nothing |]
expToExpExp (InfixE Maybe Exp
Nothing Exp
e (Just Exp
e1)) = [| InfixE Nothing $(expToExpExp e) (Just $(expToExpExp e1)) |]
expToExpExp (InfixE (Just Exp
e0) Exp
e (Just Exp
e1)) = [| InfixE (Just $(expToExpExp e0)) $(expToExpExp e) (Just $(expToExpExp e1)) |]
#if __GLASGOW_HASKELL__ >= 810
expToExpExp (TupE [Maybe Exp]
es) = [| TupE $(do ees <- mapM (expToExpExp.fromJust) es
jees <- sequence [ [| Just $(return ee) |] | ee <- ees ]
return $ ListE jees ) |]
#else
expToExpExp (TupE es) = [| TupE $((return . ListE) =<< mapM expToExpExp es) |]
#endif
expToExpExp (CondE Exp
e0 Exp
e1 Exp
e2) = [| CondE $(expToExpExp e0) $(expToExpExp e1) $(expToExpExp e2) |]
expToExpExp (ListE [Exp]
es) = [| ListE $((return . ListE) =<< mapM expToExpExp es) |]
expToExpExp e :: Exp
e@(LitE (CharL Char
c)) = [| LitE (CharL $(return e)) |]
expToExpExp e :: Exp
e@(LitE (StringL String
s)) = [| LitE (StringL $(return e)) |]
expToExpExp e :: Exp
e@(LitE (IntegerL Integer
c)) = [| LitE (IntegerL $(return e)) |]
expToExpExp e :: Exp
e@(LitE (RationalL Rational
s)) = [| LitE (RationalL $(return e)) |]
expToExpExp (SigE Exp
e Type
t) = [| SigE $(expToExpExp e) $(typeToExpType t) |]
expToExpExp Exp
e = [| VarE (mkName $(return $ LitE (StringL (show e)))) |]
typeToExpType :: Type -> ExpQ
typeToExpType :: Type -> ExpQ
typeToExpType (ForallT [TyVarBndr]
ns [] Type
t) = [| ForallT (map (plainTV . mkName) $(return $ ListE $ map (LitE . StringL . showTypeName . unPlainTV) ns)) [] $(typeToExpType t) |]
typeToExpType (ForallT [TyVarBndr]
_ (Type
_:[Type]
_) Type
_) = String -> ExpQ
forall a. HasCallStack => String -> a
error String
"typeToExpType: Type classes are not implemented yet."
typeToExpType (ConT Name
name) = [| ConT (mkName $(nameToNameStr showTypeName name)) |]
typeToExpType (VarT Name
name) = [| VarT (mkName $(nameToNameStr showTypeName name)) |]
typeToExpType (AppT Type
t0 Type
t1) = [| AppT $(typeToExpType t0) $(typeToExpType t1) |]
typeToExpType (TupleT Int
n) = [| TupleT $(return $ LitE (IntegerL (toInteger n))) |]
typeToExpType Type
ArrowT = [| ArrowT |]
typeToExpType Type
ListT = [| ListT |]
patToExpPat :: Pat -> ExpQ
patToExpPat (VarP Name
name) = [| VarP (mkName $(nameToNameStr showVarName name)) |]
patToExpPat (TupP [Pat]
ps) = [| TupP $(liftM ListE $ mapM patToExpPat ps) |]
patToExpPat (ConP Name
name [Pat]
ps) = [| ConP (mkName $(nameToNameStr showVarName name)) $(liftM ListE $ mapM patToExpPat ps) |]
patToExpPat (InfixP Pat
p0 Name
name Pat
p1) = [| InfixP $(patToExpPat p0) (mkName $(nameToNameStr showVarName name)) $(patToExpPat p1) |]
patToExpPat (TildeP Pat
p) = [| TildeP $(patToExpPat p) |]
patToExpPat (AsP Name
name Pat
p) = [| AsP (mkName $(nameToNameStr showVarName name)) $(patToExpPat p) |]
patToExpPat Pat
WildP = [| WildP |]
patToExpPat (ListP [Pat]
ps) = [| ListP $(liftM ListE $ mapM patToExpPat ps) |]
patToExpPat (SigP Pat
p Type
t) = [| SigP $(patToExpPat p) $(typeToExpType t) |]
patToExpPat (LitP (IntegerL Integer
i)) = [| LitP (IntegerL $(return $ LitE (IntegerL i))) |]
patToExpPat (LitP (CharL Char
c)) = [| LitP (CharL $(return $ LitE (CharL c))) |]
patToExpPat (LitP (StringL String
cs)) = [| LitP (StringL $(return $ LitE (StringL cs))) |]
patToExpPat (LitP (RationalL Rational
r)) = [| LitP (RationalL $(return $ LitE (RationalL r))) |]
decsToExpDecs :: [Dec] -> ExpQ
decsToExpDecs [Dec]
ds = ([Exp] -> Exp) -> Q [Exp] -> ExpQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> ExpQ) -> Q [Exp] -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Dec -> ExpQ) -> [Dec] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> ExpQ
decToExpDec [Dec]
ds
decToExpDec :: Dec -> ExpQ
decToExpDec (FunD Name
name [Clause]
clauses) = [| FunD (mkName $(nameToNameStr showTypeName name)) $(liftM ListE $ mapM clauseToExpClause clauses) |]
decToExpDec (ValD Pat
pat (NormalB Exp
e) [Dec]
decs) = [| ValD $(patToExpPat pat) (NormalB $(expToExpExp e)) $(liftM ListE $ mapM decToExpDec decs) |]
decToExpDec (SigD Name
name Type
ty) = [| SigD (mkName $(nameToNameStr showTypeName name)) $(typeToExpType ty) |]
decToExpDec Dec
d = String -> ExpQ
forall a. HasCallStack => String -> a
error (Dec -> String
forall a. Show a => a -> String
show Dec
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : unsupported")
clauseToExpClause :: Clause -> ExpQ
clauseToExpClause (Clause [Pat]
pats (NormalB Exp
e) [Dec]
decs) = [| Clause $(liftM ListE $ mapM patToExpPat pats) (NormalB $(expToExpExp e)) $(liftM ListE $ mapM decToExpDec decs) |]
#if __GLASGOW_HASKELL__ < 710
instance Ord Type where
compare (ForallT _ [] t0) (ForallT _ [] t1) = compare t0 t1
compare (ForallT _ [] _) _ = GT
compare _ (ForallT _ _ _ ) = LT
compare (VarT n0) (VarT n1) = compare n0 n1
compare (VarT _) _ = GT
compare _ (VarT _) = LT
compare (ConT n0) (ConT n1) = compare n0 n1
compare (ConT _) _ = GT
compare _ (ConT _) = LT
compare (TupleT n0) (TupleT n1) = compare n0 n1
compare (TupleT _) _ = GT
compare _ (TupleT _) = LT
compare ArrowT ArrowT = EQ
compare ArrowT _ = GT
compare _ ArrowT = LT
compare ListT ListT = EQ
compare ListT _ = GT
compare _ ListT = LT
compare (AppT f0 x0) (AppT f1 x1) = case compare f0 f1 of EQ -> compare x0 x1
o -> o
#endif
#endif
\end{code}