import HsSyn -- Lots of it
import IfaceType
import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache )
-import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) )
+import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) )
import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc,
isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace, rdrNameModule )
import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
import Lexer ( P, failSpanMsgP )
+import Kind ( liftedTypeKind )
import HscTypes ( GenAvailInfo(..) )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
- DNCallSpec(..), DNKind(..))
+ DNCallSpec(..), DNKind(..), CLabelString )
import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc,
occNameUserString, isValOcc )
-import BasicTypes ( initialVersion )
-import TyCon ( DataConDetails(..) )
+import BasicTypes ( initialVersion, StrictnessMark(..) )
import Module ( ModuleName )
import SrcLoc
-import CStrings ( CLabelString )
import CmdLineOpts ( opt_InPackage )
import OrdList ( OrdList, fromOL )
import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag )
extract_ty (HsPArrTy ty) acc = extract_lty ty acc
extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys
extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
-extract_ty (HsPredTy p) acc = extract_pred (unLoc p) acc
+extract_ty (HsPredTy p) acc = extract_pred p acc
extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
extract_ty (HsParTy ty) acc = extract_lty ty acc
extract_ty (HsNumTy num) acc = acc
ifVrcs = [] }
hsIfaceDecl (TyClD decl@(TyData {}))
- = IfaceData { ifND = tcdND decl,
- ifName = rdrNameOcc (tcdName decl),
+ = IfaceData { ifName = rdrNameOcc (tcdName decl),
ifTyVars = hsIfaceTvs (tcdTyVars decl),
ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
- ifCons = Unknown, ifRec = NonRecursive,
+ ifCons = hsIfaceCons (tcdND decl) (tcdCons decl),
+ ifRec = NonRecursive,
ifVrcs = [], ifGeneric = False }
-- I'm not sure that [] is right for ifVrcs, but
-- since we don't use them I'm not going to fiddle
hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)
+hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls
+hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified",
+ = IfAbstractTyCon -- not "no constructors"
+
+hsIfaceCons DataType cons -- data type
+ = IfDataTyCon (map (hsIfaceCon . unLoc) cons)
+
+hsIfaceCons NewType [con] -- newtype
+ = IfNewTyCon (hsIfaceCon (unLoc con))
+
+
+hsIfaceCon :: ConDecl RdrName -> IfaceConDecl
+hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details)
+ = IfaceConDecl (get_occ lname) is_infix
+ (hsIfaceTvs ex_tvs)
+ (hsIfaceCtxt (unLoc ex_ctxt))
+ (map (hsIfaceLType . getBangType . unLoc) args)
+ (map (hsStrictMark . getBangStrictness . unLoc) args)
+ flds
+ where
+ (is_infix, args, flds) = case details of
+ PrefixCon args -> (False, args, [])
+ InfixCon a1 a2 -> (True, [a1,a2], [])
+ RecCon fs -> (False, map snd fs, map (get_occ . fst) fs)
+ get_occ lname = rdrNameOcc (unLoc lname)
+
+hsStrictMark :: HsBang -> StrictnessMark
+-- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request
+-- but in an hi-boot file it's interpreted as the Truth!
+hsStrictMark HsNoBang = NotMarkedStrict
+hsStrictMark HsStrict = MarkedStrict
+hsStrictMark HsUnbox = MarkedUnboxed
+
hsIfaceName rdr_name -- Qualify unqualifed occurrences
-- with the module name
| isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
hsIfaceType (HsParTy t) = hsIfaceLType t
-hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p)
+hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p)
hsIfaceType (HsKindSig t _) = hsIfaceLType t
hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum"
hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy"
hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
-----------
-hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind)
-hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)
+hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind)
+hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k)
-----------
hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
-- Watch out.. in ...deriving( Show )... we use checkPred on
-- the list of partially applied predicates in the deriving,
-- so there can be zero args.
-checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) )
+checkPred (L spn (HsPredTy (HsIParam n ty)))
= return (L spn (HsIParam n ty))
checkPred (L spn ty)
= check spn ty []
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
where
- check (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
- = return (L spn (HsPredTy (L spn (HsClassP t args))))
+ check (HsTyVar t) args | not (isRdrTyVar t)
+ = return (L spn (HsPredTy (HsClassP t args)))
check (HsAppTy l r) args = check (unLoc l) (r:args)
check (HsParTy t) args = check (unLoc t) args
check _ _ = parseError spn "Malformed context in instance header"
HsType ty -> return (TypePat ty)
_ -> patFail loc
-checkAPat loc _ = patFail loc
-
checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
checkPatField (n,e) = do
p <- checkLPat e
checkValDef
:: LHsExpr RdrName
-> Maybe (LHsType RdrName)
- -> GRHSs RdrName
+ -> Located (GRHSs RdrName)
-> P (HsBind RdrName)
-checkValDef lhs opt_sig grhss
+checkValDef lhs opt_sig (L rhs_span grhss)
| Just (f,inf,es) <- isFunLhs lhs []
= if isQual (unLoc f)
then parseError (getLoc f) ("Qualified name in function definition: " ++
showRdrName (unLoc f))
else do ps <- checkPatterns es
- return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
- -- TODO: span is wrong
+ let match_span = combineSrcSpans (getLoc lhs) rhs_span
+ return (FunBind f inf [L match_span (Match ps opt_sig grhss)])
+ -- the span of the match covers the entire equation. That isn't
+ -- quite right, but it'll do for now.
| otherwise = do
lhs <- checkPattern lhs
return (PatBind lhs grhss)
+
checkValSig
:: LHsExpr RdrName
projects / ghc-hetmet.git / blobdiff