compiler/hsSyn/Convert.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 This module converts Template Haskell syntax into HsSyn
   7
   8 \begin{code}
   9 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
  10                 convertToHsType, thRdrNameGuesses ) where
  11
  12 import HsSyn as Hs
  13 import qualified Class
  14 import RdrName
  15 import qualified Name
  16 import Module
  17 import RdrHsSyn
  18 import qualified OccName
  19 import OccName
  20 import SrcLoc
  21 import Type
  22 import TysWiredIn
  23 import BasicTypes
  24 import ForeignCall
  25 import Char
  26 import List
  27 import Unique
  28 import MonadUtils
  29 import ErrUtils
  30 import Bag
  31 import FastString
  32 import Outputable
  33
  34 import Language.Haskell.TH as TH hiding (sigP)
  35 import Language.Haskell.TH.Syntax as TH
  36
  37 import GHC.Exts
  38
  39 -------------------------------------------------------------------
  40 --              The external interface
  41
  42 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
  43 convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds)
  44
  45 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
  46 convertToHsExpr loc e
  47   = case initCvt loc (cvtl e) of
  48         Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH expression:")
  49                                     <+> text (show e)))
  50         Right res -> Right res
  51
  52 convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
  53 convertToPat loc e
  54   = case initCvt loc (cvtPat e) of
  55         Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH pattern:")
  56                                     <+> text (show e)))
  57         Right res -> Right res
  58
  59 convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
  60 convertToHsType loc t = initCvt loc (cvtType t)
  61
  62
  63 -------------------------------------------------------------------
  64 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
  65         -- Push down the source location;
  66         -- Can fail, with a single error message
  67
  68 -- NB: If the conversion succeeds with (Right x), there should
  69 --     be no exception values hiding in x
  70 -- Reason: so a (head []) in TH code doesn't subsequently
  71 --         make GHC crash when it tries to walk the generated tree
  72
  73 -- Use the loc everywhere, for lack of anything better
  74 -- In particular, we want it on binding locations, so that variables bound in
  75 -- the spliced-in declarations get a location that at least relates to the splice point
  76
  77 instance Monad CvtM where
  78   return x       = CvtM $ \_   -> Right x
  79   (CvtM m) >>= k = CvtM $ \loc -> case m loc of
  80                                     Left err -> Left err
  81                                     Right v  -> unCvtM (k v) loc
  82
  83 initCvt :: SrcSpan -> CvtM a -> Either Message a
  84 initCvt loc (CvtM m) = m loc
  85
  86 force :: a -> CvtM a
  87 force a = a `seq` return a
  88
  89 failWith :: Message -> CvtM a
  90 failWith m = CvtM (\_ -> Left full_msg)
  91    where
  92      full_msg = m $$ ptext (sLit "When splicing generated code into the program")
  93
  94 returnL :: a -> CvtM (Located a)
  95 returnL x = CvtM (\loc -> Right (L loc x))
  96
  97 wrapL :: CvtM a -> CvtM (Located a)
  98 wrapL (CvtM m) = CvtM (\loc -> case m loc of
  99                           Left err -> Left err
 100                           Right v  -> Right (L loc v))
 101
 102 -------------------------------------------------------------------
 103 cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName)
 104 cvtTop d@(TH.ValD _ _ _)
 105   = do { L loc d' <- cvtBind d
 106        ; return (L loc $ Hs.ValD d') }
 107
 108 cvtTop d@(TH.FunD _ _)
 109   = do { L loc d' <- cvtBind d
 110        ; return (L loc $ Hs.ValD d') }
 111
 112 cvtTop (TH.SigD nm typ)
 113   = do  { nm' <- vNameL nm
 114         ; ty' <- cvtType typ
 115         ; returnL $ Hs.SigD (TypeSig nm' ty') }
 116
 117 cvtTop (TySynD tc tvs rhs)
 118   = do  { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
 119         ; rhs' <- cvtType rhs
 120         ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
 121
 122 cvtTop (DataD ctxt tc tvs constrs derivs)
 123   = do  { stuff <- cvt_tycl_hdr ctxt tc tvs
 124         ; cons' <- mapM cvtConstr constrs
 125         ; derivs' <- cvtDerivs derivs
 126         ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') }
 127
 128 cvtTop (NewtypeD ctxt tc tvs constr derivs)
 129   = do  { stuff <- cvt_tycl_hdr ctxt tc tvs
 130         ; con' <- cvtConstr constr
 131         ; derivs' <- cvtDerivs derivs
 132         ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') }
 133
 134 cvtTop (ClassD ctxt cl tvs fds decs)
 135   = do  { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
 136         ; fds'  <- mapM cvt_fundep fds
 137         ; let (ats, bind_sig_decs) = partition isFamilyD decs
 138         ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
 139         ; ats' <- mapM cvtTop ats
 140         ; let ats'' = map unTyClD ats'
 141         ; returnL $
 142             TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' ats'' []
 143                                                         -- no docs in TH ^^
 144         }
 145   where
 146     isFamilyD (FamilyD _ _ _) = True
 147     isFamilyD _               = False
 148
 149 cvtTop (InstanceD ctxt ty decs)
 150   = do  { let (ats, bind_sig_decs) = partition isFamInstD decs
 151         ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
 152         ; ats' <- mapM cvtTop ats
 153         ; let ats'' = map unTyClD ats'
 154         ; ctxt' <- cvtContext ctxt
 155         ; L loc pred' <- cvtPredTy ty
 156         ; inst_ty' <- returnL $
 157                         mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
 158         ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats'')
 159         }
 160   where
 161     isFamInstD (DataInstD _ _ _ _ _)    = True
 162     isFamInstD (NewtypeInstD _ _ _ _ _) = True
 163     isFamInstD (TySynInstD _ _ _)       = True
 164     isFamInstD _                        = False
 165
 166 cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
 167
 168 cvtTop (FamilyD flav tc tvs)
 169   = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
 170        ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' Nothing)
 171                                                                  -- FIXME: kinds
 172        }
 173   where
 174     cvtFamFlavour TypeFam = TypeFamily
 175     cvtFamFlavour DataFam = DataFamily
 176
 177 cvtTop (DataInstD ctxt tc tys constrs derivs)
 178   = do { stuff <- cvt_tyinst_hdr ctxt tc tys
 179        ; cons' <- mapM cvtConstr constrs
 180        ; derivs' <- cvtDerivs derivs
 181        ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs')
 182        }
 183
 184 cvtTop (NewtypeInstD ctxt tc tys constr derivs)
 185   = do { stuff <- cvt_tyinst_hdr ctxt tc tys
 186        ; con' <- cvtConstr constr
 187        ; derivs' <- cvtDerivs derivs
 188        ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs')
 189        }
 190
 191 cvtTop (TySynInstD tc tys rhs)
 192   = do  { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
 193         ; rhs' <- cvtType rhs
 194         ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
 195
 196 -- FIXME: This projection is not nice, but to remove it, cvtTop should be
 197 --        refactored.
 198 unTyClD :: LHsDecl a -> LTyClDecl a
 199 unTyClD (L l (TyClD d)) = L l d
 200 unTyClD _               = panic "Convert.unTyClD: internal error"
 201
 202 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name]
 203              -> CvtM ( LHsContext RdrName
 204                      , Located RdrName
 205                      , [LHsTyVarBndr RdrName]
 206                      , Maybe [LHsType RdrName])
 207 cvt_tycl_hdr cxt tc tvs
 208   = do { cxt' <- cvtContext cxt
 209        ; tc'  <- tconNameL tc
 210        ; tvs' <- cvtTvs tvs
 211        ; return (cxt', tc', tvs', Nothing)
 212        }
 213
 214 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
 215                -> CvtM ( LHsContext RdrName
 216                        , Located RdrName
 217                        , [LHsTyVarBndr RdrName]
 218                        , Maybe [LHsType RdrName])
 219 cvt_tyinst_hdr cxt tc tys
 220   = do { cxt' <- cvtContext cxt
 221        ; tc'  <- tconNameL tc
 222        ; tvs  <- concatMapM collect tys
 223        ; tvs' <- cvtTvs tvs
 224        ; tys' <- mapM cvtType tys
 225        ; return (cxt', tc', tvs', Just tys')
 226        }
 227   where
 228     collect (ForallT _ _ _)
 229       = failWith $ text "Forall type not allowed as type parameter"
 230     collect (VarT tv)    = return [tv]
 231     collect (ConT _)     = return []
 232     collect (TupleT _)   = return []
 233     collect ArrowT       = return []
 234     collect ListT        = return []
 235     collect (AppT t1 t2)
 236       = do { tvs1 <- collect t1
 237            ; tvs2 <- collect t2
 238            ; return $ tvs1 ++ tvs2
 239            }
 240
 241 ---------------------------------------------------
 242 --      Data types
 243 -- Can't handle GADTs yet
 244 ---------------------------------------------------
 245
 246 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
 247
 248 cvtConstr (NormalC c strtys)
 249   = do  { c'   <- cNameL c
 250         ; cxt' <- returnL []
 251         ; tys' <- mapM cvt_arg strtys
 252         ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
 253
 254 cvtConstr (RecC c varstrtys)
 255   = do  { c'    <- cNameL c
 256         ; cxt'  <- returnL []
 257         ; args' <- mapM cvt_id_arg varstrtys
 258         ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
 259
 260 cvtConstr (InfixC st1 c st2)
 261   = do  { c' <- cNameL c
 262         ; cxt' <- returnL []
 263         ; st1' <- cvt_arg st1
 264         ; st2' <- cvt_arg st2
 265         ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
 266
 267 cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
 268   = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
 269
 270 cvtConstr (ForallC tvs ctxt con)
 271   = do  { L _ con' <- cvtConstr con
 272         ; tvs'  <- cvtTvs tvs
 273         ; ctxt' <- cvtContext ctxt
 274         ; case con' of
 275             ConDecl l _ [] (L _ []) x ResTyH98 _
 276               -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
 277             _ -> panic "ForallC: Can't happen" }
 278
 279 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 280 cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
 281 cvt_arg (NotStrict, ty) = cvtType ty
 282
 283 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
 284 cvt_id_arg (i, str, ty)
 285   = do  { i' <- vNameL i
 286         ; ty' <- cvt_arg (str,ty)
 287         ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
 288
 289 cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
 290 cvtDerivs [] = return Nothing
 291 cvtDerivs cs = do { cs' <- mapM cvt_one cs
 292                   ; return (Just cs') }
 293         where
 294           cvt_one c = do { c' <- tconName c
 295                          ; returnL $ HsPredTy $ HsClassP c' [] }
 296
 297 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
 298 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
 299
 300 noExistentials :: [LHsTyVarBndr RdrName]
 301 noExistentials = []
 302
 303 ------------------------------------------
 304 --      Foreign declarations
 305 ------------------------------------------
 306
 307 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 308 cvtForD (ImportF callconv safety from nm ty)
 309   | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
 310   = do  { nm' <- vNameL nm
 311         ; ty' <- cvtType ty
 312         ; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis
 313         ; return $ ForeignImport nm' ty' i }
 314
 315   | otherwise
 316   = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent")
 317   where
 318     safety' = case safety of
 319                      Unsafe     -> PlayRisky
 320                      Safe       -> PlaySafe False
 321                      Threadsafe -> PlaySafe True
 322
 323 cvtForD (ExportF callconv as nm ty)
 324   = do  { nm' <- vNameL nm
 325         ; ty' <- cvtType ty
 326         ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
 327         ; return $ ForeignExport nm' ty' e }
 328
 329 cvt_conv :: TH.Callconv -> CCallConv
 330 cvt_conv TH.CCall   = CCallConv
 331 cvt_conv TH.StdCall = StdCallConv
 332
 333 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 334 parse_ccall_impent nm s
 335  = case lex_ccall_impent s of
 336        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
 337        Just ["wrapper"] -> Just (nilFS, CWrapper)
 338        Just ("static":ts) -> parse_ccall_impent_static nm ts
 339        Just ts -> parse_ccall_impent_static nm ts
 340        Nothing -> Nothing
 341
 342 parse_ccall_impent_static :: String
 343                           -> [String]
 344                           -> Maybe (FastString, CImportSpec)
 345 parse_ccall_impent_static nm ts
 346  = let ts' = case ts of
 347                  [       "&", cid] -> [       cid]
 348                  [fname, "&"     ] -> [fname     ]
 349                  [fname, "&", cid] -> [fname, cid]
 350                  _                 -> ts
 351    in case ts' of
 352           [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
 353           [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
 354           [          ]              -> Just (nilFS,              mk_cid nm)
 355           [fname     ]              -> Just (mkFastString fname, mk_cid nm)
 356           _                         -> Nothing
 357     where is_cid :: String -> Bool
 358           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
 359           mk_cid :: String -> CImportSpec
 360           mk_cid  = CFunction . StaticTarget . mkFastString
 361
 362 lex_ccall_impent :: String -> Maybe [String]
 363 lex_ccall_impent "" = Just []
 364 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
 365 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
 366 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
 367 lex_ccall_impent xs = case span is_valid xs of
 368                           ("", _) -> Nothing
 369                           (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
 370     where is_valid :: Char -> Bool
 371           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
 372
 373
 374 ---------------------------------------------------
 375 --              Declarations
 376 ---------------------------------------------------
 377
 378 cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName)
 379 cvtDecs [] = return EmptyLocalBinds
 380 cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds
 381                 ; return (HsValBinds (ValBindsIn binds sigs)) }
 382
 383 cvtBindsAndSigs :: [TH.Dec] -> CvtM (Bag (LHsBind RdrName), [LSig RdrName])
 384 cvtBindsAndSigs ds
 385   = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs
 386        ; return (listToBag binds', sigs') }
 387   where
 388     (sigs, binds) = partition is_sig ds
 389
 390     is_sig (TH.SigD _ _) = True
 391     is_sig _             = False
 392
 393 cvtSig :: TH.Dec -> CvtM (LSig RdrName)
 394 cvtSig (TH.SigD nm ty)
 395   = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') }
 396 cvtSig _ = panic "Convert.cvtSig: Signature expected"
 397
 398 cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
 399 -- Used only for declarations in a 'let/where' clause,
 400 -- not for top level decls
 401 cvtBind (TH.ValD (TH.VarP s) body ds)
 402   = do  { s' <- vNameL s
 403         ; cl' <- cvtClause (Clause [] body ds)
 404         ; returnL $ mkFunBind s' [cl'] }
 405
 406 cvtBind (TH.FunD nm cls)
 407   | null cls
 408   = failWith (ptext (sLit "Function binding for")
 409                     <+> quotes (text (TH.pprint nm))
 410                     <+> ptext (sLit "has no equations"))
 411   | otherwise
 412   = do  { nm' <- vNameL nm
 413         ; cls' <- mapM cvtClause cls
 414         ; returnL $ mkFunBind nm' cls' }
 415
 416 cvtBind (TH.ValD p body ds)
 417   = do  { p' <- cvtPat p
 418         ; g' <- cvtGuard body
 419         ; ds' <- cvtDecs ds
 420         ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds',
 421                               pat_rhs_ty = void, bind_fvs = placeHolderNames } }
 422
 423 cvtBind d
 424   = failWith (sep [ptext (sLit "Illegal kind of declaration in where clause"),
 425                    nest 2 (text (TH.pprint d))])
 426
 427 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
 428 cvtClause (Clause ps body wheres)
 429   = do  { ps' <- cvtPats ps
 430         ; g'  <- cvtGuard body
 431         ; ds' <- cvtDecs wheres
 432         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
 433
 434
 435 -------------------------------------------------------------------
 436 --              Expressions
 437 -------------------------------------------------------------------
 438
 439 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
 440 cvtl e = wrapL (cvt e)
 441   where
 442     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
 443     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
 444     cvt (LitE l)
 445       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
 446       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
 447
 448     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
 449     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
 450                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
 451     cvt (TupE [e])     = cvt e  -- Singleton tuples treated like nothing (just parens)
 452     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
 453     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
 454                             ; return $ HsIf x' y' z' }
 455     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
 456     cvt (CaseE e ms)
 457        | null ms       = failWith (ptext (sLit "Case expression with no alternatives"))
 458        | otherwise     = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
 459                             ; return $ HsCase e' (mkMatchGroup ms') }
 460     cvt (DoE ss)       = cvtHsDo DoExpr ss
 461     cvt (CompE ss)     = cvtHsDo ListComp ss
 462     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
 463     cvt (ListE xs)     = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
 464     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
 465                                           ; e' <- returnL $ OpApp x' s' undefined y'
 466                                           ; return $ HsPar e' }
 467     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
 468                                           ; sec <- returnL $ SectionR s' y'
 469                                           ; return $ HsPar sec }
 470     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
 471                                           ; sec <- returnL $ SectionL x' s'
 472                                           ; return $ HsPar sec }
 473     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 474
 475     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
 476                               ; return $ ExprWithTySig e' t' }
 477     cvt (RecConE c flds) = do { c' <- cNameL c
 478                               ; flds' <- mapM cvtFld flds
 479                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
 480     cvt (RecUpdE e flds) = do { e' <- cvtl e
 481                               ; flds' <- mapM cvtFld flds
 482                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
 483
 484 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
 485 cvtFld (v,e)
 486   = do  { v' <- vNameL v; e' <- cvtl e
 487         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
 488
 489 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 490 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
 491 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
 492 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 493 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 494
 495 -------------------------------------
 496 --      Do notation and statements
 497 -------------------------------------
 498
 499 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
 500 cvtHsDo do_or_lc stmts
 501   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
 502   | otherwise
 503   = do  { stmts' <- cvtStmts stmts
 504         ; let body = case last stmts' of
 505                         L _ (ExprStmt body _ _) -> body
 506                         _                       -> panic "Malformed body"
 507         ; return $ HsDo do_or_lc (init stmts') body void }
 508
 509 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
 510 cvtStmts = mapM cvtStmt
 511
 512 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
 513 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 514 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 515 cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
 516 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
 517                        where
 518                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 519
 520 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 521 cvtMatch (TH.Match p body decs)
 522   = do  { p' <- cvtPat p
 523         ; g' <- cvtGuard body
 524         ; decs' <- cvtDecs decs
 525         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
 526
 527 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
 528 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 529 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
 530
 531 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
 532 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 533                               ; g' <- returnL $ mkExprStmt ge'
 534                               ; returnL $ GRHS [g'] rhs' }
 535 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 536                               ; returnL $ GRHS gs' rhs' }
 537
 538 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 539 cvtOverLit (IntegerL i)
 540   = do { force i; return $ mkHsIntegral i placeHolderType}
 541 cvtOverLit (RationalL r)
 542   = do { force r; return $ mkHsFractional r placeHolderType}
 543 cvtOverLit (StringL s)
 544   = do { let { s' = mkFastString s }
 545        ; force s'
 546        ; return $ mkHsIsString s' placeHolderType
 547        }
 548 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 549 -- An Integer is like an (overloaded) '3' in a Haskell source program
 550 -- Similarly 3.5 for fractionals
 551
 552 cvtLit :: Lit -> CvtM HsLit
 553 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 554 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
 555 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 556 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 557 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 558 cvtLit (StringL s)
 559   = do { let { s' = mkFastString s }
 560        ; force s'
 561        ; return $ HsString s'
 562        }
 563 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
 564
 565 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 566 cvtPats pats = mapM cvtPat pats
 567
 568 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 569 cvtPat pat = wrapL (cvtp pat)
 570
 571 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 572 cvtp (TH.LitP l)
 573   | overloadedLit l   = do { l' <- cvtOverLit l
 574                            ; return (mkNPat l' Nothing) }
 575                                   -- Not right for negative patterns;
 576                                   -- need to think about that!
 577   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 578 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 579 cvtp (TupP [p])       = cvtp p
 580 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 581 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 582 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 583                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 584 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 585 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 586 cvtp TH.WildP         = return $ WildPat void
 587 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 588                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 589 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 590 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 591
 592 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 593 cvtPatFld (s,p)
 594   = do  { s' <- vNameL s; p' <- cvtPat p
 595         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 596
 597 -----------------------------------------------------------
 598 --      Types and type variables
 599
 600 cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName]
 601 cvtTvs tvs = mapM cvt_tv tvs
 602
 603 cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName)
 604 cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }
 605
 606 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 607 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 608
 609 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
 610 cvtPred (TH.ClassP cla tys)
 611   = do { cla' <- if isVarName cla then tName cla else tconName cla
 612        ; tys' <- mapM cvtType tys
 613        ; returnL $ HsClassP cla' tys'
 614        }
 615 cvtPred (TH.EqualP ty1 ty2)
 616   = do { ty1' <- cvtType ty1
 617        ; ty2' <- cvtType ty2
 618        ; returnL $ HsEqualP ty1' ty2'
 619        }
 620
 621 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
 622 cvtPredTy ty
 623   = do  { (head, tys') <- split_ty_app ty
 624         ; case head of
 625             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 626             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 627             _       -> failWith (ptext (sLit "Malformed predicate") <+>
 628                        text (TH.pprint ty)) }
 629
 630 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 631 cvtType ty = do { (head_ty, tys') <- split_ty_app ty
 632                 ; case head_ty of
 633                     TupleT n | length tys' == n         -- Saturated
 634                              -> if n==1 then return (head tys') -- Singleton tuples treated
 635                                                                 -- like nothing (ie just parens)
 636                                         else returnL (HsTupleTy Boxed tys')
 637                              | n == 1    -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 638                              | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 639                     ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 640                            | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
 641                     ListT  | [x']    <- tys' -> returnL (HsListTy x')
 642                            | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
 643                     VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 644                     ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 645
 646                     ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs
 647                                                          ; cxt' <- cvtContext cxt
 648                                                          ; ty'  <- cvtType ty
 649                                                          ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' }
 650                     _       -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 651              }
 652   where
 653     mk_apps head_ty []       = returnL head_ty
 654     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
 655                                   ; mk_apps (HsAppTy head_ty' ty) tys }
 656
 657 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 658 split_ty_app ty = go ty []
 659   where
 660     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 661     go f as           = return (f,as)
 662
 663 -----------------------------------------------------------
 664
 665
 666 -----------------------------------------------------------
 667 -- some useful things
 668
 669 overloadedLit :: Lit -> Bool
 670 -- True for literals that Haskell treats as overloaded
 671 overloadedLit (IntegerL  _) = True
 672 overloadedLit (RationalL _) = True
 673 overloadedLit _             = False
 674
 675 void :: Type.Type
 676 void = placeHolderType
 677
 678 --------------------------------------------------------------------
 679 --      Turning Name back into RdrName
 680 --------------------------------------------------------------------
 681
 682 -- variable names
 683 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 684 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 685
 686 vNameL n = wrapL (vName n)
 687 vName n = cvtName OccName.varName n
 688
 689 -- Constructor function names; this is Haskell source, hence srcDataName
 690 cNameL n = wrapL (cName n)
 691 cName n = cvtName OccName.dataName n
 692
 693 -- Type variable names
 694 tName n = cvtName OccName.tvName n
 695
 696 -- Type Constructor names
 697 tconNameL n = wrapL (tconName n)
 698 tconName n = cvtName OccName.tcClsName n
 699
 700 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 701 cvtName ctxt_ns (TH.Name occ flavour)
 702   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 703   | otherwise                   = force (thRdrName ctxt_ns occ_str flavour)
 704   where
 705     occ_str = TH.occString occ
 706
 707 okOcc :: OccName.NameSpace -> String -> Bool
 708 okOcc _  []      = False
 709 okOcc ns str@(c:_)
 710   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
 711   | otherwise                 = startsConId c || startsConSym c || str == "[]"
 712
 713 -- Determine the name space of a name in a type
 714 --
 715 isVarName :: TH.Name -> Bool
 716 isVarName (TH.Name occ _)
 717   = case TH.occString occ of
 718       ""    -> False
 719       (c:_) -> startsVarId c || startsVarSym c
 720
 721 badOcc :: OccName.NameSpace -> String -> SDoc
 722 badOcc ctxt_ns occ
 723   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
 724         <+> ptext (sLit "name:") <+> quotes (text occ)
 725
 726 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 727 -- This turns a Name into a RdrName
 728 -- The passed-in name space tells what the context is expecting;
 729 --      use it unless the TH name knows what name-space it comes
 730 --      from, in which case use the latter
 731 --
 732 -- ToDo: we may generate silly RdrNames, by passing a name space
 733 --       that doesn't match the string, like VarName ":+",
 734 --       which will give confusing error messages later
 735 --
 736 -- The strict applications ensure that any buried exceptions get forced
 737 thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
 738 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 739 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 740 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 741 thRdrName ctxt_ns occ TH.NameS
 742   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 743   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 744
 745 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
 746 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 747
 748 thRdrNameGuesses :: TH.Name -> [RdrName]
 749 thRdrNameGuesses (TH.Name occ flavour)
 750   -- This special case for NameG ensures that we don't generate duplicates in the output list
 751   | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
 752   | otherwise                         = [ thRdrName gns occ_str flavour
 753                                         | gns <- guessed_nss]
 754   where
 755     -- guessed_ns are the name spaces guessed from looking at the TH name
 756     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 757                 | otherwise                       = [OccName.varName, OccName.tvName]
 758     occ_str = TH.occString occ
 759
 760 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 761 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 762 -- We must generate an Exact name, just as the parser does
 763 isBuiltInOcc ctxt_ns occ
 764   = case occ of
 765         ":"              -> Just (Name.getName consDataCon)
 766         "[]"             -> Just (Name.getName nilDataCon)
 767         "()"             -> Just (tup_name 0)
 768         '(' : ',' : rest -> go_tuple 2 rest
 769         _                -> Nothing
 770   where
 771     go_tuple n ")"          = Just (tup_name n)
 772     go_tuple n (',' : rest) = go_tuple (n+1) rest
 773     go_tuple _ _            = Nothing
 774
 775     tup_name n
 776         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
 777         | otherwise                        = Name.getName (tupleCon Boxed n)
 778
 779 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 780 mk_uniq_occ ns occ uniq
 781   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 782         -- The idea here is to make a name that
 783         -- a) the user could not possibly write, and
 784         -- b) cannot clash with another NameU
 785         -- Previously I generated an Exact RdrName with mkInternalName.
 786         -- This works fine for local binders, but does not work at all for
 787         -- top-level binders, which must have External Names, since they are
 788         -- rapidly baked into data constructors and the like.  Baling out
 789         -- and generating an unqualified RdrName here is the simple solution
 790
 791 -- The packing and unpacking is rather turgid :-(
 792 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 793 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 794
 795 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 796 mk_ghc_ns TH.DataName  = OccName.dataName
 797 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 798 mk_ghc_ns TH.VarName   = OccName.varName
 799
 800 mk_mod :: TH.ModName -> ModuleName
 801 mk_mod mod = mkModuleName (TH.modString mod)
 802
 803 mk_pkg :: TH.ModName -> PackageId
 804 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 805
 806 mk_uniq :: Int# -> Unique
 807 mk_uniq u = mkUniqueGrimily (I# u)
 808 \end{code}
 809