extractHsTyRdrTyVars,
extractHsRhoRdrTyVars, extractGenericPatTyVars,
- mkHsOpApp, mkClassDecl,
+ mkHsOpApp, mkClassDecl,
mkHsNegApp, mkHsIntegral, mkHsFractional,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
checkPrecP, -- Int -> P Int
checkContext, -- HsType -> P HsContext
checkPred, -- HsType -> P HsPred
- checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
- checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
+ checkTyClHdr, -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
+ checkTyVars, -- [LHsType RdrName] -> P ()
+ checkSynHdr, -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
+ checkKindSigs, -- [LTyClDecl RdrName] -> P ()
checkInstType, -- HsType -> P HsType
checkPattern, -- HsExp -> P HsPat
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
import Panic
import List ( isSuffixOf, nubBy )
+import Monad ( unless )
\end{code}
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
-mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
+mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats
= ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
tcdFDs = fds,
tcdSigs = sigs,
- tcdMeths = mbinds
+ tcdMeths = mbinds,
+ tcdATs = ats
}
-mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
+mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
= TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
- tcdTyVars = tyvars, tcdCons = data_cons,
+ tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
tcdKindSig = ksig, tcdDerivs = maybe_deriv }
\end{code}
where (L l' b', ds') = getMonoBind (L l b) ds
go (d : ds) = d : go ds
+-- Declaration list may only contain value bindings and signatures
+--
cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName
cvBindGroup binding
- = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
- ValBindsIn mbs sigs
- }
+ = case cvBindsAndSigs binding of
+ (mbs, sigs, []) -> -- list of type decls *always* empty
+ ValBindsIn mbs sigs
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
- -> (Bag (LHsBind RdrName), [LSig RdrName])
+ -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
-- Input decls contain just value bindings and signatures
+-- and in case of class or instance declarations also
+-- associated type declarations
cvBindsAndSigs fb = go (fromOL fb)
where
- go [] = (emptyBag, [])
- go (L l (SigD s) : ds) = (bs, L l s : ss)
- where (bs,ss) = go ds
- go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
- where (b',ds') = getMonoBind (L l b) ds
- (bs,ss) = go ds'
+ go [] = (emptyBag, [], [])
+ go (L l (SigD s) : ds) = (bs, L l s : ss, ts)
+ where (bs, ss, ts) = go ds
+ go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts)
+ where (b', ds') = getMonoBind (L l b) ds
+ (bs, ss, ts) = go ds'
+ go (L l (TyClD t): ds) = (bs, ss, L l t : ts)
+ where (bs, ss, ts) = go ds
-----------------------------------------------------------------------------
-- Group function bindings into equation groups
getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
-> (LHsBind RdrName, [LHsDecl RdrName])
-- Suppose (b',ds') = getMonoBind b ds
--- ds is a *reversed* list of parsed bindings
+-- ds is a list of parsed bindings
-- b is a MonoBinds that has just been read off the front
-- Then b' is the result of grouping more equations from ds that
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (L loc bind@(FunBind { fun_id = L _ f, fun_matches = MatchGroup mtchs _ })) binds
- | has_args mtchs
- = go mtchs loc binds
+getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
+ fun_matches = MatchGroup mtchs1 _ })) binds
+ | has_args mtchs1
+ = go is_infix1 mtchs1 loc1 binds
where
- go mtchs1 loc1 (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_matches = MatchGroup mtchs2 _ })) : binds)
- | f == f2 = go (mtchs2++mtchs1) loc binds
- where loc = combineSrcSpans loc1 loc2
- go mtchs1 loc binds
- = (L loc (bind { fun_matches = mkMatchGroup (reverse mtchs1) }), binds)
+ go is_infix mtchs loc
+ (L loc2 (ValD (FunBind { fun_id = L _ f2, fun_infix = is_infix2,
+ fun_matches = MatchGroup mtchs2 _ })) : binds)
+ | f1 == f2 = go (is_infix || is_infix2) (mtchs2 ++ mtchs)
+ (combineSrcSpans loc loc2) binds
+ go is_infix mtchs loc binds
+ = (L loc (makeFunBind fun_id1 is_infix (reverse mtchs)), binds)
-- Reverse the final matches, to get it back in the right order
getMonoBind bind binds = (bind, binds)
ty -> do dict_ty <- checkDictTy (L l ty)
return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
-checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-checkTyVars tvs
- = mapM chk tvs
+-- Check whether the given list of type parameters are all type variables
+-- (possibly with a kind signature). If the second argument is `False',
+-- only type variables are allowed and we raise an error on encountering a
+-- non-variable; otherwise, we allow non-variable arguments and return the
+-- entire list of parameters.
+--
+checkTyVars :: [LHsType RdrName] -> P ()
+checkTyVars tparms = mapM_ chk tparms
where
- -- Check that the name space is correct!
+ -- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+ | isRdrTyVar tv = return ()
chk (L l (HsTyVar tv))
- | isRdrTyVar tv = return (L l (UserTyVar tv))
- chk (L l other)
- = parseError l "Type found where type variable expected"
-
-checkSynHdr :: LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName])
-checkSynHdr ty = do { (_, tc, tvs) <- checkTyClHdr (noLoc []) ty
- ; return (tc, tvs) }
-
+ | isRdrTyVar tv = return ()
+ chk (L l other) =
+ parseError l "Type found where type variable expected"
+
+-- Check whether the type arguments in a type synonym head are simply
+-- variables. If not, we have a type equation of a type function and return
+-- all patterns. If yes, we return 'Nothing' as the third component to
+-- indicate a vanilla type synonym.
+--
+checkSynHdr :: LHsType RdrName
+ -> Bool -- is type instance?
+ -> P (Located RdrName, -- head symbol
+ [LHsTyVarBndr RdrName], -- parameters
+ [LHsType RdrName]) -- type patterns
+checkSynHdr ty isTyInst =
+ do { (_, tc, tvs, tparms) <- checkTyClHdr (noLoc []) ty
+ ; unless isTyInst $ checkTyVars tparms
+ ; return (tc, tvs, tparms) }
+
+
+-- Well-formedness check and decomposition of type and class heads.
+--
checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
- -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
+ -> P (LHsContext RdrName, -- the type context
+ Located RdrName, -- the head symbol (type or class name)
+ [LHsTyVarBndr RdrName], -- free variables of the non-context part
+ [LHsType RdrName]) -- parameters of head symbol
-- The header of a type or class decl should look like
-- (C a, D b) => T a b
-- or T a b
-- or a + b
-- etc
+-- With associated types, we can also have non-variable parameters; ie,
+-- T Int [a]
+-- The unaltered parameter list is returned in the fourth component of the
+-- result. Eg, for
+-- T Int [a]
+-- we return
+-- ('()', 'T', ['a'], ['Int', '[a]'])
checkTyClHdr (L l cxt) ty
- = do (tc, tvs) <- gol ty []
+ = do (tc, tvs, parms) <- gol ty []
mapM_ chk_pred cxt
- return (L l cxt, tc, tvs)
+ return (L l cxt, tc, tvs, parms)
where
gol (L l ty) acc = go l ty acc
go l (HsTyVar tc) acc
- | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs ->
- return (L l tc, tvs)
- go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs ->
- return (tc, tvs)
+ | not (isRdrTyVar tc) = do
+ tvs <- extractTyVars acc
+ return (L l tc, tvs, acc)
+ go l (HsOpTy t1 tc t2) acc = do
+ tvs <- extractTyVars (t1:t2:acc)
+ return (tc, tvs, acc)
go l (HsParTy ty) acc = gol ty acc
go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
- go l other acc = parseError l "Malformed LHS to type of class declaration"
+ go l other acc =
+ parseError l "Malformed head of type or class declaration"
-- The predicates in a type or class decl must all
-- be HsClassPs. They need not all be type variables,
chk_pred (L l _)
= parseError l "Malformed context in type or class declaration"
-
+-- Extract the type variables of a list of type parameters.
+--
+-- * Type arguments can be complex type terms (needed for associated type
+-- declarations).
+--
+extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+extractTyVars tvs = collects [] tvs
+ where
+ -- Collect all variables (1st arg serves as an accumulator)
+ collect tvs (L l (HsForAllTy _ _ _ _)) =
+ parseError l "Forall type not allowed as type parameter"
+ collect tvs (L l (HsTyVar tv))
+ | isRdrTyVar tv = return $ L l (UserTyVar tv) : tvs
+ | otherwise = return tvs
+ collect tvs (L l (HsBangTy _ _ )) =
+ parseError l "Bang-style type annotations not allowed as type parameter"
+ collect tvs (L l (HsAppTy t1 t2 )) = do
+ tvs' <- collect tvs t2
+ collect tvs' t1
+ collect tvs (L l (HsFunTy t1 t2 )) = do
+ tvs' <- collect tvs t2
+ collect tvs' t1
+ collect tvs (L l (HsListTy t )) = collect tvs t
+ collect tvs (L l (HsPArrTy t )) = collect tvs t
+ collect tvs (L l (HsTupleTy _ ts )) = collects tvs ts
+ collect tvs (L l (HsOpTy t1 _ t2 )) = do
+ tvs' <- collect tvs t2
+ collect tvs' t1
+ collect tvs (L l (HsParTy t )) = collect tvs t
+ collect tvs (L l (HsNumTy t )) = return tvs
+ collect tvs (L l (HsPredTy t )) =
+ parseError l "Predicate not allowed as type parameter"
+ collect tvs (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ | isRdrTyVar tv =
+ return $ L l (KindedTyVar tv k) : tvs
+ | otherwise =
+ parseError l "Kind signature only allowed for type variables"
+ collect tvs (L l (HsSpliceTy t )) =
+ parseError l "Splice not allowed as type parameter"
+
+ -- Collect all variables of a list of types
+ collects tvs [] = return tvs
+ collects tvs (t:ts) = do
+ tvs' <- collects tvs ts
+ collect tvs' t
+
+-- Check that associated type declarations of a class are all kind signatures.
+--
+checkKindSigs :: [LTyClDecl RdrName] -> P ()
+checkKindSigs = mapM_ check
+ where
+ check (L l tydecl)
+ | isKindSigDecl tydecl
+ || isSynDecl tydecl = return ()
+ | otherwise =
+ parseError l "Type declaration in a class must be a kind signature or synonym default"
+
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
= check t
NegApp (L _ (HsOverLit pos_lit)) _
-> return (mkNPat pos_lit (Just noSyntaxExpr))
- SectionR (L _ (HsVar bang)) e
- | bang == bang_RDR -> checkLPat e >>= (return . BangPat)
+ SectionR (L _ (HsVar bang)) e -- (! x)
+ | bang == bang_RDR
+ -> do { bang_on <- extension bangPatEnabled
+ ; if bang_on then checkLPat e >>= (return . BangPat)
+ else parseError loc "Illegal bang-pattern (use -fbang-patterns)" }
+
ELazyPat e -> checkLPat e >>= (return . LazyPat)
EAsPat n e -> checkLPat e >>= (return . AsPat n)
ExprWithTySig e t -> checkLPat e >>= \e ->
-> Located (GRHSs RdrName)
-> P (HsBind RdrName)
+checkValDef lhs (Just sig) grhss
+ -- x :: ty = rhs parses as a *pattern* binding
+ = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
+
checkValDef lhs opt_sig grhss
= do { mb_fun <- isFunLhs lhs
; case mb_fun of
| otherwise
= do ps <- checkPatterns pats
let match_span = combineSrcSpans lhs_loc rhs_span
- matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
- return (FunBind { fun_id = fun, fun_infix = is_infix, fun_matches = matches,
- fun_co_fn = idCoercion, bind_fvs = placeHolderNames })
+ return (makeFunBind fun is_infix [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.
+makeFunBind :: Located id -> Bool -> [LMatch id] -> HsBind id
+-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
+makeFunBind fn is_infix ms
+ = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
+ fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
+
checkPatBind lhs (L _ grhss)
= do { lhs <- checkPattern lhs
; return (PatBind lhs grhss placeHolderType placeHolderNames) }
checkValSig (L l other) ty
= parseError l "Invalid type signature"
-mkGadtDecl
- :: Located RdrName
- -> LHsType RdrName -- assuming HsType
- -> ConDecl RdrName
-mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl
- { con_name = name
- , con_explicit = Implicit
- , con_qvars = qvars
- , con_cxt = cxt
- , con_details = PrefixCon args
- , con_res = ResTyGADT res
- }
- where
- (args, res) = splitHsFunType ty
-mkGadtDecl name ty = ConDecl
- { con_name = name
- , con_explicit = Implicit
- , con_qvars = []
- , con_cxt = noLoc []
- , con_details = PrefixCon args
- , con_res = ResTyGADT res
- }
- where
- (args, res) = splitHsFunType ty
+mkGadtDecl :: Located RdrName
+ -> LHsType RdrName -- assuming HsType
+ -> ConDecl RdrName
+mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = mk_gadt_con name qvars cxt ty
+mkGadtDecl name ty = mk_gadt_con name [] (noLoc []) ty
+
+mk_gadt_con name qvars cxt ty
+ = ConDecl { con_name = name
+ , con_explicit = Implicit
+ , con_qvars = qvars
+ , con_cxt = cxt
+ , con_details = PrefixCon []
+ , con_res = ResTyGADT ty }
+ -- NB: we put the whole constr type into the ResTyGADT for now;
+ -- the renamer will unravel it once it has sorted out
+ -- operator fixities
-- A variable binding is parsed as a FunBind.
| not (isRdrDataCon f) = return (Just (L loc f, False, es))
go (L _ (HsApp f e)) es = go f (e:es)
go (L _ (HsPar e)) es@(_:_) = go e es
+
+ -- For infix function defns, there should be only one infix *function*
+ -- (though there may be infix *datacons* involved too). So we don't
+ -- need fixity info to figure out which function is being defined.
+ -- a `K1` b `op` c `K2` d
+ -- must parse as
+ -- (a `K1` b) `op` (c `K2` d)
+ -- The renamer checks later that the precedences would yield such a parse.
+ --
+ -- There is a complication to deal with bang patterns.
+ --
+ -- ToDo: what about this?
+ -- x + 1 `op` y = ...
+
go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
| Just (e',es') <- splitBang e
= do { bang_on <- extension bangPatEnabled
; if bang_on then go e' (es' ++ es)
else return (Just (L loc' op, True, (l:r:es))) }
-- No bangs; behave just like the next case
- | not (isRdrDataCon op)
+ | not (isRdrDataCon op) -- We have found the function!
= return (Just (L loc' op, True, (l:r:es)))
- | otherwise
+ | otherwise -- Infix data con; keep going
= do { mb_l <- go l es
; case mb_l of
Just (op', True, j : k : es')
-> P (HsDecl RdrName)
mkImport (CCall cconv) safety (entity, v, ty) = do
importSpec <- parseCImport entity cconv safety v
- return (ForD (ForeignImport v ty importSpec False))
+ return (ForD (ForeignImport v ty importSpec))
mkImport (DNCall ) _ (entity, v, ty) = do
spec <- parseDImport entity
- return $ ForD (ForeignImport v ty (DNImport spec) False)
+ return $ ForD (ForeignImport v ty (DNImport spec))
-- parse the entity string of a foreign import declaration for the `ccall' or
-- `stdcall' calling convention'
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
mkExport (CCall cconv) (L loc entity, v, ty) = return $
- ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
+ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity