diff options
Diffstat (limited to 'compiler/parser')
| -rw-r--r-- | compiler/parser/Parser.y | 52 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 54 |
2 files changed, 83 insertions, 23 deletions
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index d72f50d871..e4ff162181 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -33,6 +33,7 @@ import Control.Monad ( unless, liftM ) import GHC.Exts import Data.Char import Control.Monad ( mplus ) +import Control.Applicative ((<$)) -- compiler/hsSyn import HsSyn @@ -79,6 +80,7 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilD -- compiler/utils import Util ( looksLikePackageName ) +import Prelude } @@ -632,9 +634,8 @@ exp_doc :: { OrdList (LIE RdrName) } -- No longer allow things like [] and (,,,) to be exported -- They are built in syntax, always available export :: { OrdList (LIE RdrName) } - : qcname_ext export_subspec {% amsu (sLL $1 $> (mkModuleImpExp $1 - (snd $ unLoc $2))) - (fst $ unLoc $2) } + : qcname_ext export_subspec {% mkModuleImpExp $1 (snd $ unLoc $2) + >>= \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)) @@ -642,18 +643,34 @@ export :: { OrdList (LIE RdrName) } export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } : {- empty -} { sL0 ([],ImpExpAbs) } - | '(' '..' ')' { sLL $1 $> ([mop $1,mcp $3,mj AnnDotdot $2] - , ImpExpAll) } - | '(' ')' { sLL $1 $> ([mop $1,mcp $2],ImpExpList []) } - | '(' qcnames ')' { sLL $1 $> ([mop $1,mcp $3],ImpExpList (reverse $2)) } - -qcnames :: { [Located RdrName] } -- A reversed list - : qcnames ',' qcname_ext {% (aa (head $1) (AnnComma, $2)) >> - return ($3 : $1) } - | qcname_ext { [$1] } - -qcname_ext :: { Located RdrName } -- Variable or data constructor - -- or tagged type constructor + | '(' qcnames ')' {% mkImpExpSubSpec (reverse (snd $2)) + >>= \(as,ie) -> return $ sLL $1 $> + (as ++ [mop $1,mcp $3] ++ fst $2, ie) } + + +qcnames :: { ([AddAnn], [Located (Maybe RdrName)]) } + : {- empty -} { ([],[]) } + | qcnames1 { $1 } + +qcnames1 :: { ([AddAnn], [Located (Maybe RdrName)]) } -- A reversed list + : qcnames1 ',' qcname_ext_w_wildcard {% case (last (snd $1)) of + l@(L _ Nothing) -> + return ([mj AnnComma $2, mj AnnDotdot l] + ,($3 : snd $1)) + l -> (aa l (AnnComma, $2) >> + return (fst $1, $3 : snd $1)) } + + + -- Annotations readded in mkImpExpSubSpec + | qcname_ext_w_wildcard { ([],[$1]) } + +-- Variable, data constructor or wildcard +-- or tagged type constructor +qcname_ext_w_wildcard :: { Located (Maybe RdrName) } + : qcname_ext { Just `fmap` $1 } + | '..' { Nothing <$ $1 } + +qcname_ext :: { Located RdrName } : qcname { $1 } | 'type' oqtycon {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) [mj AnnType $1,mj AnnVal $2] } @@ -726,7 +743,10 @@ maybeas :: { ([AddAnn],Located (Maybe ModuleName)) } | {- empty -} { ([],noLoc Nothing) } maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) } - : impspec { L (gl $1) (Just (unLoc $1)) } + : impspec {% let (b, ie) = unLoc $1 in + checkImportSpec ie + >>= \checkedIe -> + return (L (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } impspec :: { Located (Bool, Located [LIE RdrName]) } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 2d2b43b480..b24ba0968a 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -56,7 +56,9 @@ module RdrHsSyn ( -- Help with processing exports ImpExpSubSpec(..), mkModuleImpExp, - mkTypeImpExp + mkTypeImpExp, + mkImpExpSubSpec, + checkImportSpec ) where @@ -87,6 +89,7 @@ import FastString import Maybes import Util import ApiAnnotation +import Data.List #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) @@ -1328,16 +1331,31 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) -------------------------------------------------------------------------------- -- Help with module system imports/exports -data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [Located RdrName] +data ImpExpSubSpec = ImpExpAbs + | ImpExpAll + | ImpExpList [Located RdrName] + | ImpExpAllWith [Located (Maybe RdrName)] -mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> IE RdrName +mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> P (IE RdrName) mkModuleImpExp n@(L l name) subs = case subs of ImpExpAbs - | isVarNameSpace (rdrNameSpace name) -> IEVar n - | otherwise -> IEThingAbs (L l name) - ImpExpAll -> IEThingAll (L l name) - ImpExpList xs -> IEThingWith (L l name) xs [] + | isVarNameSpace (rdrNameSpace name) -> return $ IEVar n + | otherwise -> return $ IEThingAbs (L l name) + ImpExpAll -> return $ IEThingAll (L l name) + ImpExpList xs -> + return $ IEThingWith (L l name) NoIEWildcard xs [] + 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] + in return (IEThingWith (L l name) pos ies []) + else parseErrorSDoc l + (text "Illegal export form (use PatternSynonyms to enable)") mkTypeImpExp :: Located RdrName -- TcCls or Var name space -> P (Located RdrName) @@ -1348,6 +1366,28 @@ mkTypeImpExp name = else parseErrorSDoc (getLoc name) (text "Illegal keyword 'type' (use ExplicitNamespaces to enable)") +checkImportSpec :: Located [LIE RdrName] -> P (Located [LIE RdrName]) +checkImportSpec ie@(L _ specs) = + case [l | (L l (IEThingWith _ (IEWildcard _) _ _)) <- specs] of + [] -> return ie + (l:_) -> importSpecError l + where + importSpecError l = + parseErrorSDoc l + (text "Illegal import form, this syntax can only be used to bundle" + $+$ text "pattern synonyms with types in module exports.") + +-- In the correct order +mkImpExpSubSpec :: [Located (Maybe RdrName)] -> P ([AddAnn], ImpExpSubSpec) +mkImpExpSubSpec [] = return ([], ImpExpList []) +mkImpExpSubSpec [L l Nothing] = + return ([\s -> addAnnotation l AnnDotdot s], ImpExpAll) +mkImpExpSubSpec xs = + if (any (isNothing . unLoc) xs) + then return $ ([], ImpExpAllWith xs) + else return $ ([], ImpExpList ([L l x | L l (Just x) <- xs])) + + ----------------------------------------------------------------------------- -- Misc utils |