-- 
-- (c) Susumu Katayama
--
MHTH used to consist of combinators which include quasi-quotes. They are moved from MagicHaskeller.lhs because Haddock dislikes quasi-quotes.
\begin{code}
-- #hide

{-# OPTIONS -XTemplateHaskell -cpp #-}
module MagicHaskeller.MHTH(expToExpExp, typeToExpType, decsToExpDecs) where 
import Language.Haskell.TH hiding (plainTV) -- Since template-haskell-2.12.0.0, TH.Lib.plainTV is exported to TH. Its definition is plainTV=PlainTV.
import System.IO.Unsafe(unsafePerformIO)
import Data.IORef
-- import Types
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))

-- This is necessary because GHC.Base.[] would not parse as expected.
showName :: Name -> String
showName :: Name -> String
showName Name
name | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== '[]  = String
"[]" -- data constructor
              | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''[] = String
"[]" -- type constructor
              | Bool
otherwise    = Name -> String
forall a. Show a => a -> String
show Name
name

-- showVarName = nameBase
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   -- Tuple section not considered, causing error.
                                     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 -> Exp
typeToExpType (TC (Con k i))      = [| TC (Con $(return $ LitE (IntegerL k)) $(return $ LitE (IntegerL i)) |]
typeToExpType (TV (Var i True k)) = [| TV (Var $(return $ LitE (IntegerL i)) True $(return $ LitE (IntegerL k)) |]
typeToExpType (TA t0 t1)          = [| TA $(typeToExpType t0) $(typeToExpType t1) |]
typeToExpType (t0 :-> t1)         = [| $(typeToExpType t0) :-> $(typeToExpType t1) |]
-}
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}