Convert.lhs 26.3 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3 4 5 6 7 8
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

This module converts Template Haskell syntax into HsSyn

\begin{code}
9
{-# OPTIONS -fno-warn-incomplete-patterns #-}
10 11 12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 15
-- for details

16
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
17
                convertToHsType, thRdrNameGuesses ) where
18 19

import HsSyn as Hs
20 21 22 23 24
import qualified Class
import RdrName
import qualified Name
import Module
import RdrHsSyn
25
import qualified OccName
26 27 28 29 30 31 32 33 34 35 36
import OccName
import SrcLoc
import Type
import TysWiredIn
import BasicTypes
import ForeignCall
import Char
import List
import Unique
import ErrUtils
import Bag
37
import FastString
38 39
import Outputable

40 41
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
42

43
import GHC.Exts
44 45 46 47 48 49 50 51

-------------------------------------------------------------------
--		The external interface

convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds)

convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
52 53
convertToHsExpr loc e 
  = case initCvt loc (cvtl e) of
54
	Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH expression:")
55 56
				    <+> text (show e)))
	Right res -> Right res
57

58 59 60
convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
convertToPat loc e
  = case initCvt loc (cvtPat e) of
61
        Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH pattern:")
62 63 64
                                    <+> text (show e)))
        Right res -> Right res

65 66 67 68
convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
convertToHsType loc t = initCvt loc (cvtType t)


69
-------------------------------------------------------------------
70 71 72 73 74 75 76 77 78
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
	-- Push down the source location;
	-- Can fail, with a single error message

-- NB: If the conversion succeeds with (Right x), there should 
--     be no exception values hiding in x
-- Reason: so a (head []) in TH code doesn't subsequently
-- 	   make GHC crash when it tries to walk the generated tree

79 80 81
-- Use the loc everywhere, for lack of anything better
-- In particular, we want it on binding locations, so that variables bound in
-- the spliced-in declarations get a location that at least relates to the splice point
82

83
instance Monad CvtM where
84
  return x       = CvtM $ \_   -> Right x
85 86 87 88 89 90 91 92 93 94 95
  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
				    Left err -> Left err
				    Right v  -> unCvtM (k v) loc

initCvt :: SrcSpan -> CvtM a -> Either Message a
initCvt loc (CvtM m) = m loc

force :: a -> CvtM a
force a = a `seq` return a

failWith :: Message -> CvtM a
96
failWith m = CvtM (\_ -> Left full_msg)
97
   where
Ian Lynagh's avatar
Ian Lynagh committed
98
     full_msg = m $$ ptext (sLit "When splicing generated code into the program")
99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119

returnL :: a -> CvtM (Located a)
returnL x = CvtM (\loc -> Right (L loc x))

wrapL :: CvtM a -> CvtM (Located a)
wrapL (CvtM m) = CvtM (\loc -> case m loc of
			  Left err -> Left err
			  Right v  -> Right (L loc v))

-------------------------------------------------------------------
cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName)
cvtTop d@(TH.ValD _ _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
cvtTop d@(TH.FunD _ _)   = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
cvtTop (TH.SigD nm typ)  = do  { nm' <- vNameL nm
				; ty' <- cvtType typ
				; returnL $ Hs.SigD (TypeSig nm' ty') }

cvtTop (TySynD tc tvs rhs)
  = do	{ tc' <- tconNameL tc
	; tvs' <- cvtTvs tvs
	; rhs' <- cvtType rhs
120
	; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
121 122 123 124 125 126 127 128 129 130 131 132 133 134 135

cvtTop (DataD ctxt tc tvs constrs derivs)
  = do	{ stuff <- cvt_tycl_hdr ctxt tc tvs
	; cons' <- mapM cvtConstr constrs
	; derivs' <- cvtDerivs derivs
	; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') }


cvtTop (NewtypeD ctxt tc tvs constr derivs)
  = do	{ stuff <- cvt_tycl_hdr ctxt tc tvs
	; con' <- cvtConstr constr
	; derivs' <- cvtDerivs derivs
	; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') }

cvtTop (ClassD ctxt cl tvs fds decs)
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
136
  = do	{ (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
137 138
	; fds'  <- mapM cvt_fundep fds
	; (binds', sigs') <- cvtBindsAndSigs decs
139 140
	; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] []
						    -- no ATs or docs in TH ^^ ^^
141
	}
142 143 144 145 146 147

cvtTop (InstanceD tys ty decs)
  = do 	{ (binds', sigs') <- cvtBindsAndSigs decs
	; ctxt' <- cvtContext tys
	; L loc pred' <- cvtPred ty
	; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
148
	; returnL $ InstD (InstDecl inst_ty' binds' sigs' [])
Thomas Schilling's avatar
Thomas Schilling committed
149
					-- no ATs in TH   ^^
150
	}
151 152 153

cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }

154 155 156 157 158
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name]
             -> CvtM (LHsContext RdrName
                     ,Located RdrName
                     ,[LHsTyVarBndr RdrName]
                     ,Maybe [LHsType RdrName])
159 160 161 162
cvt_tycl_hdr cxt tc tvs
  = do	{ cxt' <- cvtContext cxt
	; tc'  <- tconNameL tc
	; tvs' <- cvtTvs tvs
163
	; return (cxt', tc', tvs', Nothing) }
164 165 166 167 168 169

---------------------------------------------------
-- 	Data types
-- Can't handle GADTs yet
---------------------------------------------------

170 171
cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)

172 173 174 175
cvtConstr (NormalC c strtys)
  = do	{ c'   <- cNameL c 
	; cxt' <- returnL []
	; tys' <- mapM cvt_arg strtys
176
	; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
177 178 179 180 181

cvtConstr (RecC c varstrtys)
  = do 	{ c'    <- cNameL c 
	; cxt'  <- returnL []
	; args' <- mapM cvt_id_arg varstrtys
182
	; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
183 184 185 186 187 188

cvtConstr (InfixC st1 c st2)
  = do 	{ c' <- cNameL c 
	; cxt' <- returnL []
	; st1' <- cvt_arg st1
	; st2' <- cvt_arg st2
189
	; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
190 191 192 193 194 195 196 197 198

cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
  = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')

cvtConstr (ForallC tvs ctxt con)
  = do	{ L _ con' <- cvtConstr con
	; tvs'  <- cvtTvs tvs
	; ctxt' <- cvtContext ctxt
	; case con' of
199 200
	    ConDecl l _ [] (L _ []) x ResTyH98 _
	      -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
201
	    _ -> panic "ForallC: Can't happen" }
202

203
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
204 205 206
cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
cvt_arg (NotStrict, ty) = cvtType ty

207
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
208 209 210 211
cvt_id_arg (i, str, ty) 
  = do	{ i' <- vNameL i
	; ty' <- cvt_arg (str,ty)
	; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
212

213
cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
214 215 216 217 218 219 220 221 222 223
cvtDerivs [] = return Nothing
cvtDerivs cs = do { cs' <- mapM cvt_one cs
		  ; return (Just cs') }
	where
	  cvt_one c = do { c' <- tconName c
			 ; returnL $ HsPredTy $ HsClassP c' [] }

cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }

224
noExistentials :: [LHsTyVarBndr RdrName]
225 226 227 228 229 230 231 232 233 234 235 236
noExistentials = []

------------------------------------------
-- 	Foreign declarations
------------------------------------------

cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
  | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
  = do	{ nm' <- vNameL nm
	; ty' <- cvtType ty
	; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis
237
	; return $ ForeignImport nm' ty' i }
238 239

  | otherwise
Ian Lynagh's avatar
Ian Lynagh committed
240
  = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent")
241 242 243 244 245 246 247 248 249 250
  where 
    safety' = case safety of
                     Unsafe     -> PlayRisky
                     Safe       -> PlaySafe False
                     Threadsafe -> PlaySafe True

cvtForD (ExportF callconv as nm ty)
  = do	{ nm' <- vNameL nm
	; ty' <- cvtType ty
	; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
251
 	; return $ ForeignExport nm' ty' e }
252

253
cvt_conv :: TH.Callconv -> CCallConv
254 255
cvt_conv TH.CCall   = CCallConv
cvt_conv TH.StdCall = StdCallConv
256

257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295
parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
parse_ccall_impent nm s
 = case lex_ccall_impent s of
       Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
       Just ["wrapper"] -> Just (nilFS, CWrapper)
       Just ("static":ts) -> parse_ccall_impent_static nm ts
       Just ts -> parse_ccall_impent_static nm ts
       Nothing -> Nothing

parse_ccall_impent_static :: String
                          -> [String]
                          -> Maybe (FastString, CImportSpec)
parse_ccall_impent_static nm ts
 = let ts' = case ts of
                 [       "&", cid] -> [       cid]
                 [fname, "&"     ] -> [fname     ]
                 [fname, "&", cid] -> [fname, cid]
                 _                 -> ts
   in case ts' of
          [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
          [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
          [          ]              -> Just (nilFS,              mk_cid nm)
          [fname     ]              -> Just (mkFastString fname, mk_cid nm)
          _                         -> Nothing
    where is_cid :: String -> Bool
          is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
          mk_cid :: String -> CImportSpec
          mk_cid  = CFunction . StaticTarget . mkFastString

lex_ccall_impent :: String -> Maybe [String]
lex_ccall_impent "" = Just []
lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
lex_ccall_impent (' ':xs) = lex_ccall_impent xs
lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
lex_ccall_impent xs = case span is_valid xs of
                          ("", _) -> Nothing
                          (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
    where is_valid :: Char -> Bool
          is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
296

297

298 299 300
---------------------------------------------------
--		Declarations
---------------------------------------------------
301

302 303 304 305
cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName)
cvtDecs [] = return EmptyLocalBinds
cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds
		; return (HsValBinds (ValBindsIn binds sigs)) }
306

307
cvtBindsAndSigs :: [TH.Dec] -> CvtM (Bag (LHsBind RdrName), [LSig RdrName])
308 309 310
cvtBindsAndSigs ds 
  = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs
       ; return (listToBag binds', sigs') }
311
  where 
312
    (sigs, binds) = partition is_sig ds
313

314
    is_sig (TH.SigD _ _) = True
315
    is_sig _             = False
316

317
cvtSig :: TH.Dec -> CvtM (LSig RdrName)
318 319
cvtSig (TH.SigD nm ty)
  = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') }
320

321
cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
322 323
-- Used only for declarations in a 'let/where' clause,
-- not for top level decls
324 325 326
cvtBind (TH.ValD (TH.VarP s) body ds) 
  = do	{ s' <- vNameL s
	; cl' <- cvtClause (Clause [] body ds)
327
	; returnL $ mkFunBind s' [cl'] }
328

329
cvtBind (TH.FunD nm cls)
330 331 332 333 334
  | null cls
  = failWith (ptext (sLit "Function binding for")
    	     	    <+> quotes (text (TH.pprint nm))
    	     	    <+> ptext (sLit "has no equations"))
  | otherwise
335 336
  = do	{ nm' <- vNameL nm
	; cls' <- mapM cvtClause cls
337
	; returnL $ mkFunBind nm' cls' }
338

339 340 341 342
cvtBind (TH.ValD p body ds)
  = do	{ p' <- cvtPat p
	; g' <- cvtGuard body
	; ds' <- cvtDecs ds
343 344
	; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds', 
			      pat_rhs_ty = void, bind_fvs = placeHolderNames } }
345 346

cvtBind d 
Ian Lynagh's avatar
Ian Lynagh committed
347
  = failWith (sep [ptext (sLit "Illegal kind of declaration in where clause"),
348 349 350 351 352 353 354 355
		   nest 2 (text (TH.pprint d))])

cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
cvtClause (Clause ps body wheres)
  = do	{ ps' <- cvtPats ps
	; g'  <- cvtGuard body
	; ds' <- cvtDecs wheres
	; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
356 357


358 359 360
-------------------------------------------------------------------
--		Expressions
-------------------------------------------------------------------
361

362 363 364 365 366 367 368 369
cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
cvtl e = wrapL (cvt e)
  where
    cvt (VarE s) 	= do { s' <- vName s; return $ HsVar s' }
    cvt (ConE s) 	= do { s' <- cName s; return $ HsVar s' }
    cvt (LitE l) 
      | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
      | otherwise	= do { l' <- cvtLit l;     return $ HsLit l' }
370

371 372 373
    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']) }
374
    cvt (TupE [e])     = cvt e	-- Singleton tuples treated like nothing (just parens)
375 376 377 378
    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' }
    cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
379 380 381
    cvt (CaseE e ms)   
       | null ms       = failWith (ptext (sLit "Case expression with no alternatives"))
       | otherwise     = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
382 383 384 385 386 387 388 389 390 391 392 393 394
			    ; return $ HsCase e' (mkMatchGroup ms') }
    cvt (DoE ss)       = cvtHsDo DoExpr ss
    cvt (CompE ss)     = cvtHsDo ListComp ss
    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
    cvt (ListE xs)     = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
    cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
					  ; e' <- returnL $ OpApp x' s' undefined y'
					  ; return $ HsPar e' }
    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
					  ; return $ SectionR s' y' }
    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
					  ; return $ SectionL x' s' }
    cvt (InfixE Nothing  s Nothing ) = cvt s	-- Can I indicate this is an infix thing?
395

396 397 398 399
    cvt (SigE e t)	 = do { e' <- cvtl e; t' <- cvtType t
			      ; return $ ExprWithTySig e' t' }
    cvt (RecConE c flds) = do { c' <- cNameL c
			      ; flds' <- mapM cvtFld flds
400
			      ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
401 402
    cvt (RecUpdE e flds) = do { e' <- cvtl e
			      ; flds' <- mapM cvtFld flds
403
			      ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
404

405
cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
406 407 408
cvtFld (v,e) 
  = do	{ v' <- vNameL v; e' <- cvtl e
	; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
409 410 411 412 413 414 415 416 417 418 419

cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
cvtDD (FromR x) 	  = do { x' <- cvtl x; return $ From x' }
cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }

-------------------------------------
-- 	Do notation and statements
-------------------------------------

420
cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
421
cvtHsDo do_or_lc stmts
422 423
  | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
  | otherwise
424 425 426 427 428
  = do	{ stmts' <- cvtStmts stmts
	; let body = case last stmts' of
			L _ (ExprStmt body _ _) -> body
	; return $ HsDo do_or_lc (init stmts') body void }

429
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452
cvtStmts = mapM cvtStmt 

cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
		       where
			 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }

cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
cvtMatch (TH.Match p body decs)
  = do 	{ p' <- cvtPat p
	; g' <- cvtGuard body
	; decs' <- cvtDecs decs
	; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }

cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
cvtGuard (GuardedB pairs) = mapM cvtpair pairs
cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }

cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
453
			      ; g' <- returnL $ mkExprStmt ge'
454 455 456 457 458
			      ; returnL $ GRHS [g'] rhs' }
cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
			      ; returnL $ GRHS gs' rhs' }

cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
459 460 461
cvtOverLit (IntegerL i)  = do { force i; return $ mkHsIntegral i placeHolderType}
cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType}
cvtOverLit (StringL s)   = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType }
462 463
-- An Integer is like an an (overloaded) '3' in a Haskell source program
-- Similarly 3.5 for fractionals
464

465 466
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
Ian Lynagh's avatar
Ian Lynagh committed
467
cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487
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 }
cvtLit (StringL s)     = do { let { s' = mkFastString s }; force s'; return $ HsString s' }

cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
cvtPats pats = mapM cvtPat pats

cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
cvtPat pat = wrapL (cvtp pat)

cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
cvtp (TH.LitP l)
  | overloadedLit l   = do { l' <- cvtOverLit l
		 	   ; return (mkNPat l' Nothing) }
		 		  -- Not right for negative patterns; 
		 		  -- need to think about that!
  | otherwise	      = do { l' <- cvtLit l; return $ Hs.LitPat l' }
cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
cvtp (TupP [p])       = cvtp p
488
cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
489 490 491 492 493 494 495
cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
			   ; return $ ConPatIn s' (InfixCon p1' p2') }
cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
cvtp TH.WildP         = return $ WildPat void
cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs 
496
		  	   ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
497 498 499
cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }

500
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
501 502 503
cvtPatFld (s,p)
  = do	{ s' <- vNameL s; p' <- cvtPat p
	; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
504

505 506
-----------------------------------------------------------
--	Types and type variables
507

508 509 510
cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName]
cvtTvs tvs = mapM cvt_tv tvs

511
cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName)
512 513 514 515 516 517 518 519 520 521 522
cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }

cvtContext :: Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }

cvtPred :: TH.Type -> CvtM (LHsPred RdrName)
cvtPred ty 
  = do	{ (head, tys') <- split_ty_app ty
	; case head of
	    ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
	    VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
Ian Lynagh's avatar
Ian Lynagh committed
523
	    _       -> failWith (ptext (sLit "Malformed predicate") <+> text (TH.pprint ty)) }
524 525

cvtType :: TH.Type -> CvtM (LHsType RdrName)
526 527 528 529 530 531 532
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"))
533 534 535 536 537 538 539 540 541 542
		             | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
		    ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
		    ListT  | [x']    <- tys' -> returnL (HsListTy x')
		    VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
		    ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }

		    ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs
							 ; cxt' <- cvtContext cxt
							 ; ty'  <- cvtType ty
							 ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' }
Ian Lynagh's avatar
Ian Lynagh committed
543
		    _       -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
544 545
	     }
  where
546 547 548
    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 }
549

550
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
551 552
split_ty_app ty = go ty []
  where
553 554
    go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
    go f as 	      = return (f,as)
555 556 557 558 559 560 561 562 563

-----------------------------------------------------------


-----------------------------------------------------------
-- some useful things

overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
564 565 566
overloadedLit (IntegerL  _) = True
overloadedLit (RationalL _) = True
overloadedLit _             = False
567 568 569 570

void :: Type.Type
void = placeHolderType

571 572 573 574
--------------------------------------------------------------------
--	Turning Name back into RdrName
--------------------------------------------------------------------

575
-- variable names
576 577 578 579
vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName

vNameL n = wrapL (vName n)
580
vName n = cvtName OccName.varName n
581

582
-- Constructor function names; this is Haskell source, hence srcDataName
583
cNameL n = wrapL (cName n)
584
cName n = cvtName OccName.dataName n 
585 586

-- Type variable names
587
tName n = cvtName OccName.tvName n
588 589

-- Type Constructor names
590
tconNameL n = wrapL (tconName n)
591
tconName n = cvtName OccName.tcClsName n
592

593 594 595 596 597 598 599 600 601 602
cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
cvtName ctxt_ns (TH.Name occ flavour)
  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
  | otherwise 		        = force (thRdrName ctxt_ns occ_str flavour)
  where
    occ_str = TH.occString occ

okOcc :: OccName.NameSpace -> String -> Bool
okOcc _  []      = False
okOcc ns str@(c:_) 
603 604
  | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
  | otherwise 	 	      = startsConId c || startsConSym c || str == "[]"
605 606 607

badOcc :: OccName.NameSpace -> String -> SDoc
badOcc ctxt_ns occ 
Ian Lynagh's avatar
Ian Lynagh committed
608 609
  = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
	<+> ptext (sLit "name:") <+> quotes (text occ)
610 611

thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
612
-- This turns a Name into a RdrName
613 614 615
-- The passed-in name space tells what the context is expecting;
--	use it unless the TH name knows what name-space it comes
-- 	from, in which case use the latter
616 617 618 619
--
-- ToDo: we may generate silly RdrNames, by passing a name space
--       that doesn't match the string, like VarName ":+", 
-- 	 which will give confusing error messages later
620 621
-- 
-- The strict applications ensure that any buried exceptions get forced
622
thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
623
thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
624 625 626 627 628 629
thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
thRdrName ctxt_ns occ TH.NameS
  | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
  | otherwise			           = mkRdrUnqual $! (mk_occ ctxt_ns occ)

630 631 632 633 634 635 636 637 638 639 640 641 642 643 644
thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)

thRdrNameGuesses :: TH.Name -> [RdrName]
thRdrNameGuesses (TH.Name occ flavour)
  -- This special case for NameG ensures that we don't generate duplicates in the output list
  | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
  | otherwise                         = [ thRdrName gns occ_str flavour
			                | gns <- guessed_nss]
  where
    -- guessed_ns are the name spaces guessed from looking at the TH name
    guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
	        | otherwise			  = [OccName.varName, OccName.tvName]
    occ_str = TH.occString occ

645 646 647 648 649 650 651 652 653
isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
-- Built in syntax isn't "in scope" so an Unqual RdrName won't do
-- We must generate an Exact name, just as the parser does
isBuiltInOcc ctxt_ns occ
  = case occ of
	":" 		 -> Just (Name.getName consDataCon)
	"[]"		 -> Just (Name.getName nilDataCon)
	"()"		 -> Just (tup_name 0)
	'(' : ',' : rest -> go_tuple 2 rest
654
	_                -> Nothing
655 656 657
  where
    go_tuple n ")" 	    = Just (tup_name n)
    go_tuple n (',' : rest) = go_tuple (n+1) rest
658
    go_tuple _ _            = Nothing
659

660
    tup_name n 
661 662
	| OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
	| otherwise 		           = Name.getName (tupleCon Boxed n)
663 664

mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
665
mk_uniq_occ ns occ uniq 
666
  = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
667 668 669 670 671 672 673 674
	-- The idea here is to make a name that 
	-- a) the user could not possibly write, and
	-- b) cannot clash with another NameU
	-- Previously I generated an Exact RdrName with mkInternalName.
	-- This works fine for local binders, but does not work at all for
	-- top-level binders, which must have External Names, since they are
	-- rapidly baked into data constructors and the like.  Baling out
	-- and generating an unqualified RdrName here is the simple solution
675

676 677
-- The packing and unpacking is rather turgid :-(
mk_occ :: OccName.NameSpace -> String -> OccName.OccName
678
mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
679

680
mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
681
mk_ghc_ns TH.DataName  = OccName.dataName
682 683 684
mk_ghc_ns TH.TcClsName = OccName.tcClsName
mk_ghc_ns TH.VarName   = OccName.varName

Simon Marlow's avatar
Simon Marlow committed
685 686 687 688 689
mk_mod :: TH.ModName -> ModuleName
mk_mod mod = mkModuleName (TH.modString mod)

mk_pkg :: TH.ModName -> PackageId
mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
690 691 692

mk_uniq :: Int# -> Unique
mk_uniq u = mkUniqueGrimily (I# u)
693
\end{code}
694