-- 
-- (c) Susumu Katayama 2009
--
MHTH is consisted 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, maybeWithTO, maybeWithPTO, newPTO, typeToExpType, unsafeWithPTO, unsafeOpWithPTO) where 
import Language.Haskell.TH
import System.IO.Unsafe(unsafePerformIO)
import Data.IORef
-- import Types
#ifdef CHTO
import MagicHaskeller.TimeOut
#endif
import Control.Monad(liftM)

import MagicHaskeller.ReadTHType(showTypeName)

unsafeWithPTO :: Maybe Int -> a -> Maybe a
#ifdef CHTO
unsafeWithPTO pto a = unsafePerformIO $ wrapExecution (
                                                       maybeWithPTO seq (return a) pto
                                                      )
maybeWithPTO :: (a -> IO () -> IO ()) -- ^ seq or deepSeq(=Control.Parallel.Strategies.sforce). For our purposes seq is enough, because @a@ is either 'Bool' or 'Ordering'.
                -> IO a -> (Maybe Int) -> IO (Maybe a)
maybeWithPTO sq = flip (maybeWithTO sq)
newPTO t = return t
#else
unsafeWithPTO _ = Just
maybeWithPTO :: c -> IO a -> b -> IO (Maybe a)
maybeWithPTO _ action _ = do a <- action
                             return (Just a)
maybeWithTO :: c -> b -> IO a -> IO (Maybe a)
maybeWithTO _ _ action = do a <- action
                            return (Just a)
newPTO = error "not implemented on this platform."
#endif

unsafeOpWithPTO :: Maybe Int -> (a->b->c) -> a -> b -> Maybe c
unsafeOpWithPTO mto op l r = unsafeWithPTO mto (op l r)

#ifdef __GLASGOW_HASKELL__
nameToNameStr :: (Name -> String) -> Name -> ExpQ
nameToNameStr shw name = return $ LitE (StringL (shw name))

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

-- showVarName = nameBase
showVarName = showName

expToExpExp :: Exp -> ExpQ
expToExpExp (VarE name) = [| VarE (mkName $(nameToNameStr showVarName name)) |]
expToExpExp (ConE name) = [| ConE (mkName $(nameToNameStr showVarName name)) |]
expToExpExp (AppE e0 e1) = [| AppE $(expToExpExp e0) $(expToExpExp e1) |]
expToExpExp (LamE ps e) = [| LamE $(liftM ListE $ mapM patToExpPat ps) $(expToExpExp e) |]  
expToExpExp (InfixE Nothing   e Nothing)   = [| InfixE Nothing                  $(expToExpExp e) Nothing |]
expToExpExp (InfixE (Just e0) e Nothing)   = [| InfixE (Just $(expToExpExp e0)) $(expToExpExp e) Nothing |]
expToExpExp (InfixE Nothing   e (Just e1)) = [| InfixE Nothing                  $(expToExpExp e) (Just $(expToExpExp e1)) |]
expToExpExp (InfixE (Just e0) e (Just e1)) = [| InfixE (Just $(expToExpExp e0)) $(expToExpExp e) (Just $(expToExpExp e1)) |]
expToExpExp (TupE es) = [| (return . AppE . TupE) =<< $((return . ListE) =<< mapM expToExpExp es) |]
expToExpExp (CondE e0 e1 e2) = [| CondE $(expToExpExp e0) $(expToExpExp e1) $(expToExpExp e2) |]
expToExpExp (ListE es) = [| (return . AppE . ListE) =<< $((return . ListE) =<< mapM expToExpExp es) |]
expToExpExp e@(LitE (CharL c))     = [| LitE (CharL     $(return e)) |]
expToExpExp e@(LitE (StringL s))   = [| LitE (StringL   $(return e)) |]
expToExpExp e@(LitE (IntegerL c))  = [| LitE (IntegerL  $(return e)) |]
expToExpExp e@(LitE (RationalL s)) = [| LitE (RationalL $(return e)) |]
expToExpExp (SigE e t)             = [| SigE $(expToExpExp e) $(typeToExpType t) |]
expToExpExp 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 (ForallT ns [] t) = [| ForallT (map mkName $(return $ ListE $ map (LitE . StringL . showTypeName) ns)) [] $(typeToExpType t) |]
typeToExpType (ForallT _ (_:_) _) = error "typeToExpType: Type classes are not implemented yet."
typeToExpType (ConT name)      = [| ConT (mkName $(nameToNameStr showTypeName name)) |]
typeToExpType (VarT name)      = [| VarT (mkName $(nameToNameStr showTypeName name)) |]
typeToExpType (AppT t0 t1)     = [| AppT $(typeToExpType t0) $(typeToExpType t1) |]
typeToExpType (TupleT n)       = [| TupleT $(return $ LitE (IntegerL (toInteger n))) |]
typeToExpType ArrowT           = [| ArrowT |]
typeToExpType ListT            = [| ListT |]

patToExpPat (VarP name) = [| VarP (mkName $(nameToNameStr showVarName name)) |]
patToExpPat (TupP ps)   = [| TupP $(liftM ListE $ mapM patToExpPat ps) |]
patToExpPat (ConP name ps) = [| ConP (mkName $(nameToNameStr showVarName name)) $(liftM ListE $ mapM patToExpPat ps) |]
patToExpPat (InfixP p0 name p1) = [| InfixP $(patToExpPat p0) (mkName $(nameToNameStr showVarName name)) $(patToExpPat p1) |]
patToExpPat (TildeP p)          = [| TildeP $(patToExpPat p) |]
patToExpPat (AsP name p)        = [| AsP (mkName $(nameToNameStr showVarName name)) $(patToExpPat p) |]
patToExpPat WildP               = [| WildP |]
patToExpPat (ListP ps)          = [| ListP $(liftM ListE $ mapM patToExpPat ps) |]
patToExpPat (SigP p t)          = [| SigP $(patToExpPat p) $(typeToExpType t) |]

#endif

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

\end{code}