module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType, thRdrName ) where
-#include "HsVersions.h"
-
import HsSyn as Hs
import qualified Class
import RdrName
convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
convertToHsExpr loc e
= case initCvt loc (cvtl e) of
- Left msg -> Left (msg $$ (ptext SLIT("When converting TH expression")
+ Left msg -> Left (msg $$ (ptext (sLit "When converting TH expression")
<+> text (show e)))
Right res -> Right res
convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
convertToPat loc e
= case initCvt loc (cvtPat e) of
- Left msg -> Left (msg $$ (ptext SLIT("When converting TH pattern")
+ Left msg -> Left (msg $$ (ptext (sLit "When converting TH pattern")
<+> text (show e)))
Right res -> Right res
failWith :: Message -> CvtM a
failWith m = CvtM (\_ -> Left full_msg)
where
- full_msg = m $$ ptext SLIT("When splicing generated code into the program")
+ full_msg = m $$ ptext (sLit "When splicing generated code into the program")
returnL :: a -> CvtM (Located a)
returnL x = CvtM (\loc -> Right (L loc x))
; L loc pred' <- cvtPred ty
; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
; returnL $ InstD (InstDecl inst_ty' binds' sigs' [])
- -- ^^no ATs in TH
+ -- no ATs in TH ^^
}
cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
; return $ ForeignImport nm' ty' i }
| otherwise
- = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent")
+ = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent")
where
safety' = case safety of
Unsafe -> PlayRisky
pat_rhs_ty = void, bind_fvs = placeHolderNames } }
cvtBind d
- = failWith (sep [ptext SLIT("Illegal kind of declaration in where clause"),
+ = failWith (sep [ptext (sLit "Illegal kind of declaration in where clause"),
nest 2 (text (TH.pprint d))])
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
- cvt (TupE [e]) = cvt e
+ cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens)
cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
; return $ HsIf x' y' z' }
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
+cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
cvtLit (CharL c) = do { force c; return $ HsChar c }
; case head of
ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' }
- _ -> failWith (ptext SLIT("Malformed predicate") <+> text (TH.pprint ty)) }
+ _ -> failWith (ptext (sLit "Malformed predicate") <+> text (TH.pprint ty)) }
cvtType :: TH.Type -> CvtM (LHsType RdrName)
-cvtType ty = do { (head, tys') <- split_ty_app ty
- ; case head of
- TupleT n | length tys' == n -> returnL (HsTupleTy Boxed tys')
- | n == 0 -> mk_apps (HsTyVar (getRdrName unitTyCon)) tys'
+cvtType ty = do { (head_ty, tys') <- split_ty_app ty
+ ; case head_ty of
+ TupleT n | length tys' == n -- Saturated
+ -> if n==1 then return (head tys') -- Singleton tuples treated
+ -- like nothing (ie just parens)
+ else returnL (HsTupleTy Boxed tys')
+ | n == 1 -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
| otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
ListT | [x'] <- tys' -> returnL (HsListTy x')
; cxt' <- cvtContext cxt
; ty' <- cvtType ty
; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' }
- _ -> failWith (ptext SLIT("Malformed type") <+> text (show ty))
+ _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
}
where
- mk_apps head [] = returnL head
- mk_apps head (ty:tys) = do { head' <- returnL head; mk_apps (HsAppTy head' ty) tys }
+ mk_apps head_ty [] = returnL head_ty
+ mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
+ ; mk_apps (HsAppTy head_ty' ty) tys }
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
split_ty_app ty = go ty []
badOcc :: OccName.NameSpace -> String -> SDoc
badOcc ctxt_ns occ
- = ptext SLIT("Illegal") <+> pprNameSpace ctxt_ns
- <+> ptext SLIT("name:") <+> quotes (text occ)
+ = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
+ <+> ptext (sLit "name:") <+> quotes (text occ)
thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
-- This turns a Name into a RdrName