Functions over HsSyn specialised to RdrName.
\begin{code}
-{-# OPTIONS -w #-}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- 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
#include "HsVersions.h"
import HsSyn -- Lots of it
+import Class ( FunDep )
+import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, isQual,
setRdrNameSpace )
extractHsRhoRdrTyVars ctxt ty
= nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])
+extract_lctxt :: Located [LHsPred RdrName] -> [Located RdrName] -> [Located RdrName]
extract_lctxt ctxt acc = foldr (extract_pred . unLoc) acc (unLoc ctxt)
-extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys
+extract_pred :: HsPred RdrName -> [Located RdrName] -> [Located RdrName]
+extract_pred (HsClassP _ tys) acc = foldr extract_lty acc tys
extract_pred (HsEqualP ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc)
-extract_pred (HsIParam n ty ) acc = extract_lty ty acc
+extract_pred (HsIParam _ ty ) acc = extract_lty ty acc
+extract_lty :: LHsType RdrName -> [Located RdrName] -> [Located RdrName]
extract_lty (L loc ty) acc
= case ty of
HsTyVar tv -> extract_tv loc tv acc
HsPredTy p -> extract_pred p acc
HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
HsParTy ty -> extract_lty ty acc
- HsNumTy num -> acc
+ HsNumTy _ -> acc
HsSpliceTy _ -> acc -- Type splices mention no type variables
- HsKindSig ty k -> extract_lty ty acc
- HsForAllTy exp [] cx ty -> extract_lctxt cx (extract_lty ty acc)
- HsForAllTy exp tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
+ HsKindSig ty _ -> extract_lty ty acc
+ HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc)
+ HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $
extract_lctxt cx (extract_lty ty []))
where
locals = hsLTyVarNames tvs
- HsDocTy ty doc -> extract_lty ty acc
+ HsDocTy ty _ -> extract_lty ty acc
extract_tv :: SrcSpan -> RdrName -> [Located RdrName] -> [Located RdrName]
extract_tv loc tv acc | isRdrTyVar tv = L loc tv : acc
= nubBy eqLocated (foldrBag get [] binds)
where
get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
- get other acc = acc
+ get _ acc = acc
get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
- get_m other acc = acc
+ get_m _ acc = acc
\end{code}
*** See "THE NAMING STORY" in HsDecls ****
\begin{code}
+mkClassDecl :: (LHsContext name, Located name, [LHsTyVarBndr name])
+ -> [Located (FunDep name)]
+ -> [LSig name]
+ -> LHsBinds name
+ -> [LTyClDecl name]
+ -> [LDocDecl name]
+ -> TyClDecl name
mkClassDecl (cxt, cname, tyvars) fds sigs mbinds ats docs
= ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
tcdFDs = fds,
tcdDocs = docs
}
+mkTyData :: NewOrData
+ -> (LHsContext name,
+ Located name,
+ [LHsTyVarBndr name],
+ Maybe [LHsType name])
+ -> Maybe Kind
+ -> [LConDecl name]
+ -> Maybe [LHsType name]
+ -> TyClDecl name
mkTyData new_or_data (context, tname, tyvars, typats) ksig data_cons maybe_deriv
= TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons,
cvBindsAndSigs fb = go (fromOL fb)
where
go [] = (emptyBag, [], [], [])
- go (L l x@(SigD s) : ds) = (bs, L l s : ss, ts, docs)
+ go (L l (SigD s) : ds) = (bs, L l s : ss, ts, docs)
where (bs, ss, ts, docs) = go ds
- go (L l x@(ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
+ go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, docs)
where (b', ds') = getMonoBind (L l b) ds
(bs, ss, ts, docs) = go ds'
go (L l (TyClD t): ds) = (bs, ss, L l t : ts, docs)
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations
-getMonoBind (L loc1 bind@(FunBind { fun_id = fun_id1@(L _ f1), fun_infix = is_infix1,
- fun_matches = MatchGroup mtchs1 _ })) binds
+getMonoBind (L loc1 (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
getMonoBind bind binds = (bind, binds)
+has_args :: [LMatch RdrName] -> Bool
has_args ((L _ (Match args _ _)) : _) = not (null args)
-- Don't group together FunBinds if they have
-- no arguments. This is necessary now that variable bindings
add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
-> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
-add gp l (SpliceD e) ds = (gp, Just (e, ds))
+add gp _ (SpliceD e) ds = (gp, Just (e, ds))
-- Class declarations: pull out the fixity signatures to the top
add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs})
add gp l (DocD d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
+add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
+
+add_sig :: LSig a -> HsValBinds a -> HsValBinds a
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
\end{code}
checkTyVars tparms = mapM_ chk tparms
where
-- Check that the name space is correct!
- chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ chk (L _ (HsKindSig (L _ (HsTyVar tv)) _))
| isRdrTyVar tv = return ()
- chk (L l (HsTyVar tv))
+ chk (L _ (HsTyVar tv))
| isRdrTyVar tv = return ()
- chk (L l other) =
+ chk (L l _) =
parseError l "Type found where type variable expected"
-- Check whether the type arguments in a type synonym head are simply
go l (HsTyVar tc) acc
| isRdrTc tc = do tvs <- extractTyVars acc
return (L l tc, tvs, acc)
- go l (HsOpTy t1 ltc@(L _ tc) t2) acc
+ go _ (HsOpTy t1 ltc@(L _ tc) t2) acc
| isRdrTc tc = do tvs <- extractTyVars (t1:t2:acc)
return (ltc, tvs, t1:t2:acc)
- go l (HsParTy ty) acc = gol ty acc
- go l (HsAppTy t1 t2) acc = gol t1 (t2:acc)
- go l other acc =
+ go _ (HsParTy ty) acc = gol ty acc
+ go _ (HsAppTy t1 t2) acc = gol t1 (t2:acc)
+ go l _ _ =
parseError l "Malformed head of type or class declaration"
-- The predicates in a type or class decl must be class predicates or
-- equational constraints. They need not all have variable-only
-- arguments, even in Haskell 98.
-- E.g. class (Monad m, Monad (t m)) => MonadT t m
- chk_pred (L l (HsClassP _ _)) = return ()
- chk_pred (L l (HsEqualP _ _)) = return ()
+ chk_pred (L _ (HsClassP _ _)) = return ()
+ chk_pred (L _ (HsEqualP _ _)) = return ()
chk_pred (L l _)
= parseError l "Malformed context in type or class declaration"
-- declarations).
--
extractTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-extractTyVars tvs = collects [] tvs
+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 (L l (HsForAllTy _ _ _ _)) =
+ const $ parseError l "Forall type not allowed as type parameter"
+ collect (L l (HsTyVar tv))
+ | isRdrTyVar tv = return . (L l (UserTyVar tv) :)
+ | otherwise = return
+ collect (L l (HsBangTy _ _ )) =
+ const $ parseError l "Bang-style type annotations not allowed as type parameter"
+ collect (L _ (HsAppTy t1 t2 )) = collect t2 >=> collect t1
+ collect (L _ (HsFunTy t1 t2 )) = collect t2 >=> collect t1
+ collect (L _ (HsListTy t )) = collect t
+ collect (L _ (HsPArrTy t )) = collect t
+ collect (L _ (HsTupleTy _ ts )) = collects ts
+ collect (L _ (HsOpTy t1 _ t2 )) = collect t2 >=> collect t1
+ collect (L _ (HsParTy t )) = collect t
+ collect (L _ (HsNumTy _ )) = return
+ collect (L l (HsPredTy _ )) =
+ const $ parseError l "Predicate not allowed as type parameter"
+ collect (L l (HsKindSig (L _ (HsTyVar tv)) k))
+ | isRdrTyVar tv =
+ return . (L l (KindedTyVar tv k) :)
+ | otherwise =
+ const $ parseError l "Kind signature only allowed for type variables"
+ collect (L l (HsSpliceTy _ )) =
+ const $ 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
+ collects [] = return
+ collects (t:ts) = collects ts >=> collect t
+
+ (f >=> g) x = f x >>= g
-- Check that associated type declarations of a class are all kind signatures.
--
-- (b) returns it separately
-- same comments apply for mdo as well
+checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
+
checkDo = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"
checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
-checkDoMDo pre nm loc ss = do
+checkDoMDo _ nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
+checkDoMDo pre nm _ ss = do
check ss
where
- check [L l (ExprStmt e _ _)] = return ([], e)
+ check [L _ (ExprStmt e _ _)] = return ([], e)
check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
" construct must be an expression")
check (s:ss) = do
= do { x <- checkLPat x; checkPat loc f (x:args) }
checkPat loc (L _ e) []
= do { p <- checkAPat loc e; return (L loc p) }
-checkPat loc pat _some_args
+checkPat loc _ _
= patFail loc
+checkAPat :: SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
checkAPat loc e = case e of
EWildPat -> return (WildPat placeHolderType)
HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
EAsPat n e -> checkLPat e >>= (return . AsPat n)
-- view pattern is well-formed if the pattern is
EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
- ExprWithTySig e t -> checkLPat e >>= \e ->
- -- Pattern signatures are parsed as sigtypes,
- -- but they aren't explicit forall points. Hence
- -- we have to remove the implicit forall here.
- let t' = case t of
- L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
- other -> other
- in
- return (SigPatIn e t')
+ ExprWithTySig e t -> do e <- checkLPat e
+ -- Pattern signatures are parsed as sigtypes,
+ -- but they aren't explicit forall points. Hence
+ -- we have to remove the implicit forall here.
+ let t' = case t of
+ L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
+ other -> other
+ return (SigPatIn e t')
-- n+k patterns
OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
| plus == plus_RDR
-> return (mkNPlusKPat (L nloc n) lit)
- OpApp l op fix r -> checkLPat l >>= \l ->
- checkLPat r >>= \r ->
- case op of
- L cl (HsVar c) | isDataOcc (rdrNameOcc c)
- -> return (ConPatIn (L cl c) (InfixCon l r))
- _ -> patFail loc
+ OpApp l op _fix r -> do l <- checkLPat l
+ r <- checkLPat r
+ case op of
+ L cl (HsVar c) | isDataOcc (rdrNameOcc c)
+ -> return (ConPatIn (L cl c) (InfixCon l r))
+ _ -> patFail loc
- HsPar e -> checkLPat e >>= (return . ParPat)
- ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
- return (ListPat ps placeHolderType)
- ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
- return (PArrPat ps placeHolderType)
+ HsPar e -> checkLPat e >>= (return . ParPat)
+ ExplicitList _ es -> do ps <- mapM (\e -> checkLPat e) es
+ return (ListPat ps placeHolderType)
+ ExplicitPArr _ es -> do ps <- mapM (\e -> checkLPat e) es
+ return (PArrPat ps placeHolderType)
- ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
- return (TuplePat ps b placeHolderType)
+ ExplicitTuple es b -> do ps <- mapM (\e -> checkLPat e) es
+ return (TuplePat ps b placeHolderType)
- RecordCon c _ (HsRecFields fs dd)
- -> mapM checkPatField fs >>= \fs ->
- return (ConPatIn c (RecCon (HsRecFields fs dd)))
+ RecordCon c _ (HsRecFields fs dd)
+ -> do fs <- mapM checkPatField fs
+ return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsQuasiQuoteE q -> return (QuasiQuotePat q)
-- Generics
HsType ty -> return (TypePat ty)
checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
; return (fld { hsRecFieldArg = p }) }
+patFail :: SrcSpan -> P a
patFail loc = parseError loc "Parse error in pattern"
fun is_infix pats opt_sig grhss
Nothing -> checkPatBind lhs grhss }
+checkFunBind :: SrcSpan
+ -> Located RdrName
+ -> Bool
+ -> [LHsExpr RdrName]
+ -> Maybe (LHsType RdrName)
+ -> Located (GRHSs RdrName)
+ -> P (HsBind RdrName)
checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
| isQual (unLoc fun)
= parseError (getLoc fun) ("Qualified name in function definition: " ++
= FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
+checkPatBind :: LHsExpr RdrName
+ -> Located (GRHSs RdrName)
+ -> P (HsBind RdrName)
checkPatBind lhs (L _ grhss)
= do { lhs <- checkPattern lhs
; return (PatBind lhs grhss placeHolderType placeHolderNames) }
checkValSig (L l (HsVar v)) ty
| isUnqual v && not (isDataOcc (rdrNameOcc v))
= return (TypeSig (L l v) ty)
-checkValSig (L l other) ty
+checkValSig (L l _) _
= parseError l "Invalid type signature"
mkGadtDecl :: Located 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 :: Located RdrName
+ -> [LHsTyVarBndr RdrName]
+ -> LHsContext RdrName
+ -> LHsType RdrName
+ -> ConDecl RdrName
mk_gadt_con name qvars cxt ty
= ConDecl { con_name = name
, con_explicit = Implicit
-- not be any OpApps inside the e's
splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
-- Splits (f ! g a b) into (f, [(! g), a, b])
-splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
+splitBang (L loc (OpApp l_arg bang@(L _ (HsVar op)) _ r_arg))
| op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
where
(arg1,argns) = split_bang r_arg []
split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
split_bang e es = (e,es)
-splitBang other = Nothing
+splitBang _ = Nothing
isFunLhs :: LHsExpr RdrName
-> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
-> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
-> P (HsExpr RdrName)
-mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c
+mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) | isRdrDataCon c
= return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp loc (fs,dd)
| null fs = parseError loc "Empty record update"
| otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
+mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
parse2 _ _ [] = d'oh
parse2 isStatic kind (('[':x):xs) =
case x of
- [] -> d'oh
- vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
+ vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
+ _ -> d'oh
parse2 isStatic kind xs = parse3 isStatic kind "" xs
parse3 isStatic kind assem [x] =
mkExport :: CallConv
-> (Located FastString, Located RdrName, LHsType RdrName)
-> P (HsDecl RdrName)
-mkExport (CCall cconv) (L loc entity, v, ty) = return $
+mkExport (CCall cconv) (L _ entity, v, ty) = return $
ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)))
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
-mkExport DNCall (L loc entity, v, ty) =
+mkExport DNCall (L _ _, v, _) =
parseError (getLoc v){-TODO: not quite right-}
"Foreign export is not yet supported for .NET"
projects / ghc-hetmet.git / commitdiff