import TysWiredIn
import BasicTypes as Hs
import ForeignCall
-import Char
import List
import Unique
import MonadUtils
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)
; 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)
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 nilFS 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
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
-
-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
- where is_cid :: String -> Bool
- is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
- mk_cid :: String -> CImportSpec
- mk_cid = CFunction . StaticTarget . mkFastString
-
-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
------------------------------------------
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' }
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