; 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
}
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')
}
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)
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]
= 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')
; 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)
| 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 nilFS cis
+ ; let i = CImport (cvt_conv callconv) safety' c_header cis
; return $ ForeignImport nm' ty' i }
| otherwise
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
- = let ts' = case ts of
- [ "&", cid] -> [ cid]
- [fname, "&" ] -> [fname ]
- [fname, "&", cid] -> [fname, cid]
- _ -> ts
- in case ts' of
- [ cid] | is_cid cid -> Just (nilFS, mk_cid cid)
- [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
- [ ] -> Just (nilFS, mk_cid nm)
- [fname ] -> Just (mkFastString fname, mk_cid nm)
- _ -> Nothing
+ = 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 == '_')
- mk_cid :: String -> CImportSpec
- mk_cid = CFunction . StaticTarget . mkFastString
+ 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
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
- cvt (ListE xs) = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
+ cvt (ListE xs)
+ | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
+ -- Note [Converting strings]
+ | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
; e' <- returnL $ OpApp x' s' undefined y'
; return $ HsPar e' }
-- An Integer is like an (overloaded) '3' in a Haskell source program
-- Similarly 3.5 for fractionals
+{- Note [Converting strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
+a string literal for "xy". Of course, we might hope to get
+(LitE (StringL "xy")), but not always, and allCharLs fails quickly
+if it isn't a literal string
+-}
+
+allCharLs :: [TH.Exp] -> Maybe String
+-- Note [Converting strings]
+allCharLs (LitE (CharL c) : xs)
+ | Just cs <- allCharLs xs = Just (c:cs)
+allCharLs [] = Just []
+allCharLs _ = Nothing
+
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
projects / ghc-hetmet.git / blobdiff