diff options
Diffstat (limited to 'compiler/parser')
| -rw-r--r-- | compiler/parser/Parser.y | 25 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 55 |
2 files changed, 51 insertions, 29 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 2b70fb7999..e0e060e053 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -793,7 +793,7 @@ export :: { OrdList (LIE RdrName) } >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) } | 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2)) [mj AnnModule $1] } - | 'pattern' qcon {% amsu (sLL $1 $> (IEVar $2)) + | 'pattern' qcon {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2)))) [mj AnnPattern $1] } export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } @@ -803,13 +803,13 @@ export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } (as ++ [mop $1,mcp $3] ++ fst $2, ie) } -qcnames :: { ([AddAnn], [Located (Maybe RdrName)]) } +qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) } : {- empty -} { ([],[]) } | qcnames1 { $1 } -qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) } -- A reversed list +qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) } -- A reversed list : qcnames1 ',' qcname_ext_w_wildcard {% case (head (snd $1)) of - l@(L _ Nothing) -> + l@(L _ ImpExpQcWildcard) -> return ([mj AnnComma $2, mj AnnDotdot l] ,(snd (unLoc $3) : snd $1)) l -> (ams (head (snd $1)) [mj AnnComma $2] >> @@ -822,14 +822,15 @@ qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) } -- A reversed list -- Variable, data constructor or wildcard -- or tagged type constructor -qcname_ext_w_wildcard :: { Located ([AddAnn],Located (Maybe RdrName)) } - : qcname_ext { sL1 $1 ([],Just `fmap` $1) } - | '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 Nothing) } - -qcname_ext :: { Located RdrName } - : qcname { $1 } - | 'type' oqtycon {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) - [mj AnnType $1,mj AnnVal $2] } +qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) } + : qcname_ext { sL1 $1 ([],$1) } + | '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard) } + +qcname_ext :: { Located ImpExpQcSpec } + : qcname { sL1 $1 (ImpExpQcName $1) } + | 'type' oqtycon {% do { n <- mkTypeImpExp $2 + ; ams (sLL $1 $> (ImpExpQcType n)) + [mj AnnType $1] } } qcname :: { Located RdrName } -- Variable or type constructor : qvar { $1 } -- Things which look like functions diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 64a60c4841..2c63c428b6 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -56,6 +56,7 @@ module RdrHsSyn ( -- Help with processing exports ImpExpSubSpec(..), + ImpExpQcSpec(..), mkModuleImpExp, mkTypeImpExp, mkImpExpSubSpec, @@ -1436,30 +1437,37 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) data ImpExpSubSpec = ImpExpAbs | ImpExpAll - | ImpExpList [Located RdrName] - | ImpExpAllWith [Located (Maybe RdrName)] + | ImpExpList [Located ImpExpQcSpec] + | ImpExpAllWith [Located ImpExpQcSpec] -mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> P (IE RdrName) -mkModuleImpExp n@(L l name) subs = +data ImpExpQcSpec = ImpExpQcName (Located RdrName) + | ImpExpQcType (Located RdrName) + | ImpExpQcWildcard + +mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE RdrName) +mkModuleImpExp (L l specname) subs = case subs of ImpExpAbs - | isVarNameSpace (rdrNameSpace name) -> return $ IEVar n - | otherwise -> IEThingAbs . L l <$> nameT - ImpExpAll -> IEThingAll . L l <$> nameT - ImpExpList xs -> - (\newName -> IEThingWith (L l newName) NoIEWildcard xs []) <$> nameT + | isVarNameSpace (rdrNameSpace name) + -> return $ IEVar (L l (ieNameFromSpec specname)) + | otherwise -> IEThingAbs . L l <$> nameT + ImpExpAll -> IEThingAll . L l <$> nameT + ImpExpList xs -> + (\newName -> IEThingWith (L l newName) NoIEWildcard (wrapped xs) []) + <$> nameT ImpExpAllWith xs -> do allowed <- extension patternSynonymsEnabled if allowed then let withs = map unLoc xs pos = maybe NoIEWildcard IEWildcard - (findIndex isNothing withs) - ies = [L l n | L l (Just n) <- xs] + (findIndex isImpExpQcWildcard withs) + ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName -> IEThingWith (L l newName) pos ies []) <$> nameT else parseErrorSDoc l (text "Illegal export form (use PatternSynonyms to enable)") where + name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name) then parseErrorSDoc l @@ -1469,7 +1477,17 @@ mkModuleImpExp n@(L l name) subs = then text "If" <+> quotes (ppr name) <+> text "is a type constructor" <+> text "then enable ExplicitNamespaces and use the 'type' keyword." else empty) - else return $ name + else return $ ieNameFromSpec specname + + ieNameVal (ImpExpQcName ln) = unLoc ln + ieNameVal (ImpExpQcType ln) = unLoc ln + ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" + + ieNameFromSpec (ImpExpQcName ln) = IEName ln + ieNameFromSpec (ImpExpQcType ln) = IEType ln + ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" + + wrapped = map (\(L l x) -> L l (ieNameFromSpec x)) mkTypeImpExp :: Located RdrName -- TcCls or Var name space -> P (Located RdrName) @@ -1492,15 +1510,18 @@ checkImportSpec ie@(L _ specs) = $+$ text "pattern synonyms with types in module exports.") -- In the correct order -mkImpExpSubSpec :: [Located (Maybe RdrName)] -> P ([AddAnn], ImpExpSubSpec) +mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [L l Nothing] = - return ([\s -> addAnnotation s AnnDotdot l], ImpExpAll) +mkImpExpSubSpec [L _ ImpExpQcWildcard] = + return ([], ImpExpAll) mkImpExpSubSpec xs = - if (any (isNothing . unLoc) xs) + if (any (isImpExpQcWildcard . unLoc) xs) then return $ ([], ImpExpAllWith xs) - else return $ ([], ImpExpList ([L l x | L l (Just x) <- xs])) + else return $ ([], ImpExpList xs) +isImpExpQcWildcard :: ImpExpQcSpec -> Bool +isImpExpQcWildcard ImpExpQcWildcard = True +isImpExpQcWildcard _ = False ----------------------------------------------------------------------------- -- Misc utils |