X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=c443fcf7de81a702ae5776a698dbb3ee0757692d;hb=b62f4e789fa4aea34ce6e857d512905054023417;hp=31a0bca2c8b3f5c5e5c31ec9ea1721a7dfdf33d6;hpb=909691a910d99495baf396fca3ab7e82f2e2eb51;p=ghc-hetmet.git diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 31a0bca..c443fcf 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -22,7 +22,6 @@ import Type import TysWiredIn import BasicTypes as Hs import ForeignCall -import Char import List import Unique import MonadUtils @@ -83,8 +82,8 @@ instance Monad CvtM where initCvt :: SrcSpan -> CvtM a -> Either Message a initCvt loc (CvtM m) = m loc -force :: a -> CvtM a -force a = a `seq` return a +force :: a -> CvtM () +force a = a `seq` return () failWith :: Message -> CvtM a failWith m = CvtM (\_ -> Left full_msg) @@ -115,31 +114,37 @@ cvtTop (TH.SigD nm typ) ; returnL $ Hs.SigD (TypeSig nm' ty') } cvtTop (TySynD tc tvs rhs) - = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') } cvtTop (DataD ctxt tc tvs constrs derivs) - = do { stuff <- cvt_tycl_hdr ctxt tc tvs + = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') } + ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing + , tcdCons = cons', tcdDerivs = derivs' }) } cvtTop (NewtypeD ctxt tc tvs constr derivs) - = do { stuff <- cvt_tycl_hdr ctxt tc tvs + = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') } + ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing + , tcdCons = [con'], tcdDerivs = derivs'}) } cvtTop (ClassD ctxt cl tvs fds decs) - = do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs + = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds ; let (ats, bind_sig_decs) = partition isFamilyD decs ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs ; ats' <- mapM cvtTop ats ; let ats'' = map unTyClD ats' ; returnL $ - TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' ats'' [] + TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' + , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' + , tcdATs = ats'', tcdDocs = [] } -- no docs in TH ^^ } where @@ -174,7 +179,7 @@ cvtTop (PragmaD prag) } cvtTop (FamilyD flav tc tvs kind) - = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; let kind' = fmap cvtKind kind ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') } @@ -183,17 +188,21 @@ cvtTop (FamilyD flav tc tvs kind) cvtFamFlavour DataFam = DataFamily cvtTop (DataInstD ctxt tc tys constrs derivs) - = do { stuff <- cvt_tyinst_hdr ctxt tc tys + = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') + ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing + , tcdCons = cons', tcdDerivs = derivs' }) } cvtTop (NewtypeInstD ctxt tc tys constr derivs) - = do { stuff <- cvt_tyinst_hdr ctxt tc tys + = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') + ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing + , tcdCons = [con'], tcdDerivs = derivs' }) } cvtTop (TySynInstD tc tys rhs) @@ -210,13 +219,12 @@ unTyClD _ = panic "Convert.unTyClD: internal error" cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] -> CvtM ( LHsContext RdrName , Located RdrName - , [LHsTyVarBndr RdrName] - , Maybe [LHsType RdrName]) + , [LHsTyVarBndr RdrName]) cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs', Nothing) + ; return (cxt', tc', tvs') } cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] @@ -259,20 +267,20 @@ cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys - ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing } + ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing } + ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') } cvtConstr (InfixC st1 c st2) = do { c' <- cNameL c ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing } + ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') } cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con')) = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con') @@ -282,8 +290,8 @@ cvtConstr (ForallC tvs ctxt con) ; tvs' <- cvtTvs tvs ; ctxt' <- cvtContext ctxt ; case con' of - ConDecl l _ [] (L _ []) x ResTyH98 _ - -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing + ConDecl { con_qvars = [], con_cxt = L _ [] } + -> returnL $ con' { con_qvars = tvs', con_cxt = ctxt' } _ -> panic "ForallC: Can't happen" } cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) @@ -316,15 +324,15 @@ noExistentials = [] cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) cvtForD (ImportF callconv safety from nm ty) - | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from - = do { nm' <- vNameL nm - ; ty' <- cvtType ty - ; let i = CImport (cvt_conv callconv) safety' c_header cis - ; return $ ForeignImport nm' ty' i } - + | Just impspec <- parseCImport (cvt_conv callconv) safety' + (mkFastString (TH.nameBase nm)) from + = do { nm' <- vNameL nm + ; ty' <- cvtType ty + ; return (ForeignImport nm' ty' impspec) + } | otherwise - = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent") - where + = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent") + where safety' = case safety of Unsafe -> PlayRisky Safe -> PlaySafe False @@ -340,61 +348,6 @@ cvt_conv :: TH.Callconv -> CCallConv cvt_conv TH.CCall = CCallConv cvt_conv TH.StdCall = StdCallConv -parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec) -parse_ccall_impent nm s - = case lex_ccall_impent s of - Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget) - Just ["wrapper"] -> Just (nilFS, CWrapper) - Just ("static":ts) -> parse_ccall_impent_static nm ts - Just ts -> parse_ccall_impent_static nm ts - Nothing -> Nothing - --- XXX we should be sharing code with RdrHsSyn.parseCImport -parse_ccall_impent_static :: String - -> [String] - -> Maybe (FastString, CImportSpec) -parse_ccall_impent_static nm ts - = case ts of - [ ] -> mkFun nilFS nm - [ "&", cid] -> mkLbl nilFS cid - [fname, "&" ] -> mkLbl (mkFastString fname) nm - [fname, "&", cid] -> mkLbl (mkFastString fname) cid - [ "&" ] -> mkLbl nilFS nm - [fname, cid] -> mkFun (mkFastString fname) cid - [ cid] - | is_cid cid -> mkFun nilFS cid - | otherwise -> mkFun (mkFastString cid) nm - -- tricky case when there's a single string: "foo.h" is a header, - -- but "foo" is a C identifier, and we tell the difference by - -- checking for a valid C identifier (see is_cid below). - _anything_else -> Nothing - - where is_cid :: String -> Bool - is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_') - - mkLbl :: FastString -> String -> Maybe (FastString, CImportSpec) - mkLbl fname lbl = Just (fname, CLabel (mkFastString lbl)) - - mkFun :: FastString -> String -> Maybe (FastString, CImportSpec) - mkFun fname lbl = Just (fname, CFunction (StaticTarget (mkFastString lbl))) - --- This code is tokenising something like "foo.h &bar", eg. --- "" -> Just [] --- "foo.h" -> Just ["foo.h"] --- "foo.h &bar" -> Just ["foo.h","&","bar"] --- "&" -> Just ["&"] --- Nothing is returned for a parse error. -lex_ccall_impent :: String -> Maybe [String] -lex_ccall_impent "" = Just [] -lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs -lex_ccall_impent (' ':xs) = lex_ccall_impent xs -lex_ccall_impent ('\t':xs) = lex_ccall_impent xs -lex_ccall_impent xs = case span is_valid xs of - ("", _) -> Nothing - (t, xs') -> fmap (t:) $ lex_ccall_impent xs' - where is_valid :: Char -> Bool - is_valid c = isAscii c && (isAlphaNum c || c `elem` "._") - ------------------------------------------ -- Pragmas ------------------------------------------ @@ -512,7 +465,7 @@ cvtl e = wrapL (cvt e) cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens) - cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed } + cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z ; return $ HsIf x' y' z' } cvt (LetE ds e) = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' } @@ -808,9 +761,10 @@ tconName n = cvtName OccName.tcClsName n cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName cvtName ctxt_ns (TH.Name occ flavour) | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) - | otherwise = force (thRdrName ctxt_ns occ_str flavour) + | otherwise = force rdr_name >> return rdr_name where occ_str = TH.occString occ + rdr_name = thRdrName ctxt_ns occ_str flavour okOcc :: OccName.NameSpace -> String -> Bool okOcc _ [] = False