getSrcLoc, getSrcSpan, getOccString,
pprInfixName, pprPrefixName, pprModulePrefix,
+ getNameDepth, setNameDepth,
-- Re-export the OccName stuff
module OccName
-- (and real!) space leaks, due to the fact that we don't look at
-- the SrcLoc in a Name all that often.
+setNameDepth :: Int -> Name -> Name
+setNameDepth depth name = name { n_occ = setOccNameDepth depth (n_occ name) }
+
+getNameDepth :: Name -> Int
+getNameDepth name = getOccNameDepth $ n_occ name
+
data NameSort
= External Module
-- Prints (if mod information is available) "Defined at <loc>" or
-- "Defined in <mod>" information for a Name.
pprNameLoc :: Name -> SDoc
- pprNameLoc name
- | isGoodSrcSpan loc = pprDefnLoc loc
- | isInternalName name || isSystemName name
- = ptext (sLit "<no location info>")
- | otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name)
- where loc = nameSrcSpan name
+ pprNameLoc name = case nameSrcSpan name of
+ RealSrcSpan s ->
+ pprDefnLoc s
+ UnhelpfulSpan _
+ | isInternalName name || isSystemName name ->
+ ptext (sLit "<no location info>")
+ | otherwise ->
+ ptext (sLit "Defined in ") <> ppr (nameModule name)
\end{code}
%************************************************************************
import TcRnTypes
import MkIface
import Id
+import Pair
import Name
import CoreSyn
import CoreSubst
+import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
import PprCore
import DsMonad
import DsExpr
import OrdList
import Data.List
import Data.IORef
+import PrelNames
+import UniqSupply
+import UniqFM
+import CoreFVs
+import Type
+import Coercion
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+
-- | Main entry point to the desugarer.
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
-- Can modify PCS by faulting in more declarations
<- case target of
HscNothing ->
return (emptyMessages,
- Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
+ Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ , undefined
+ ))
_ -> do
(binds_cvr,ds_hpc_info, modBreaks)
<- if (opt_Hpc
; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mapMaybeM dsRule rules
; ds_vects <- mapM dsVect vects
+ ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
+ ; hetmet_esc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name else return undefined
+ ; hetmet_flatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flatten_name else return undefined
+ ; hetmet_unflatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_unflatten_name else return undefined
+ ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined
+ ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined
+ ; hetmet_PGArrow_unit <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_unit_name else return undefined
+ ; hetmet_PGArrow_tensor <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_tensor_name else return undefined
+ ; hetmet_PGArrow_exponent <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_exponent_name else return undefined
+ ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined
+ ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined
+ ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined
+ ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined
+ ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined
+ ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined
+ ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined
+ ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined
+ ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined
+ ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined
+ ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined
+ ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined
+ ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined
+ ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined
+ ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined
+ ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined
+ ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined
+ ; hetmet_pga_loopl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_loopl_name else return undefined
+ ; hetmet_pga_loopr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_loopr_name else return undefined
; let hpc_init
| opt_Hpc = hpcInitCode mod ds_hpc_info
| otherwise = empty
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
, ds_fords `appendStubC` hpc_init
- , ds_hpc_info, modBreaks) }
+ , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc
+ , hetmet_flatten
+ , hetmet_unflatten
+ , hetmet_flattened_id
+ , hetmet_PGArrow
+ , hetmet_PGArrow_unit
+ , hetmet_PGArrow_tensor
+ , hetmet_PGArrow_exponent
+ , hetmet_pga_id
+ , hetmet_pga_comp
+ , hetmet_pga_first
+ , hetmet_pga_second
+ , hetmet_pga_cancell
+ , hetmet_pga_cancelr
+ , hetmet_pga_uncancell
+ , hetmet_pga_uncancelr
+ , hetmet_pga_assoc
+ , hetmet_pga_unassoc
+ , hetmet_pga_copy
+ , hetmet_pga_drop
+ , hetmet_pga_swap
+ , hetmet_pga_applyl
+ , hetmet_pga_applyr
+ , hetmet_pga_curryl
+ , hetmet_pga_curryr
+ , hetmet_pga_loopl
+ , hetmet_pga_loopr
+ ) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
- Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks
- Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
++ Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks
+ , hetmet_brak, hetmet_esc
+ , hetmet_flatten
+ , hetmet_unflatten
+ , hetmet_flattened_id
+ , hetmet_PGArrow
+ , hetmet_PGArrow_unit
+ , hetmet_PGArrow_tensor
+ , hetmet_PGArrow_exponent
+ , hetmet_pga_id
+ , hetmet_pga_comp
+ , hetmet_pga_first
+ , hetmet_pga_second
+ , hetmet_pga_cancell
+ , hetmet_pga_cancelr
+ , hetmet_pga_uncancell
+ , hetmet_pga_uncancelr
+ , hetmet_pga_assoc
+ , hetmet_pga_unassoc
+ , hetmet_pga_copy
+ , hetmet_pga_drop
+ , hetmet_pga_swap
+ , hetmet_pga_applyl
+ , hetmet_pga_applyr
+ , hetmet_pga_curryl
+ , hetmet_pga_curryr
+ , hetmet_pga_loopl
+ , hetmet_pga_loopr
+ ) -> do
- { -- Add export flags to bindings
- keep_alive <- readIORef keep_var
- ; let (rules_for_locals, rules_for_imps)
+ { -- Add export flags to bindings
+ keep_alive <- readIORef keep_var
+ ; let (rules_for_locals, rules_for_imps)
= partition isLocalRule all_rules
final_prs = addExportFlagsAndRules target
- export_set keep_alive rules_for_locals (fromOL all_prs)
+ export_set keep_alive rules_for_locals (fromOL all_prs)
- final_pgm = combineEvBinds ds_ev_binds final_prs
+ final_pgm = let comb = combineEvBinds ds_ev_binds final_prs
+ in if dopt Opt_F_simpleopt_before_flatten dflags
+ then comb
+ else simplifyBinds comb
- -- Notice that we put the whole lot in a big Rec, even the foreign binds
- -- When compiling PrelFloat, which defines data Float = F# Float#
- -- we want F# to be in scope in the foreign marshalling code!
- -- You might think it doesn't matter, but the simplifier brings all top-level
- -- things into the in-scope set before simplifying; so we get no unfolding for F#!
-
- -- Lint result if necessary, and print
- ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
- (vcat [ pprCoreBindings final_pgm
- , pprRules rules_for_imps ])
+ -- Notice that we put the whole lot in a big Rec, even the foreign binds
+ -- When compiling PrelFloat, which defines data Float = F# Float#
+ -- we want F# to be in scope in the foreign marshalling code!
+ -- You might think it doesn't matter, but the simplifier brings all top-level
+ -- things into the in-scope set before simplifying; so we get no unfolding for F#!
- -- Lint result if necessary, and print
- ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
- (vcat [ pprCoreBindings final_pgm
- , pprRules rules_for_imps ])
+ ; (final_pgm', rules_for_imps') <- if dopt Opt_F_simpleopt_before_flatten dflags
+ then simpleOptPgm dflags final_pgm rules_for_imps
+ else return (final_pgm, rules_for_imps)
+
+ ; ds_binds <- if dopt Opt_F_coqpass dflags
+ then do { us <- mkSplitUniqSupply '~'
+ ; let do_flatten = dopt Opt_F_flatten dflags
+ ; let do_skolemize = dopt Opt_F_skolemize dflags
+ ; return (coqPassCoreToCore
+ do_flatten
+ do_skolemize
+ hetmet_brak
+ hetmet_esc
+ hetmet_flatten
+ hetmet_unflatten
+ hetmet_flattened_id
+ us
+ final_pgm'
+ hetmet_PGArrow
+ hetmet_PGArrow_unit
+ hetmet_PGArrow_tensor
+ hetmet_PGArrow_exponent
+ hetmet_pga_id
+ hetmet_pga_comp
+ hetmet_pga_first
+ hetmet_pga_second
+ hetmet_pga_cancell
+ hetmet_pga_cancelr
+ hetmet_pga_uncancell
+ hetmet_pga_uncancelr
+ hetmet_pga_assoc
+ hetmet_pga_unassoc
+ hetmet_pga_copy
+ hetmet_pga_drop
+ hetmet_pga_swap
+ hetmet_pga_applyl
+ hetmet_pga_applyr
+ hetmet_pga_curryl
+ hetmet_pga_curryr
+ hetmet_pga_loopl
+ hetmet_pga_loopr
+ )
+ }
+ else return final_pgm
+
+ ; (ds_binds', ds_rules_for_imps) <- if dopt Opt_F_simpleopt_before_flatten dflags
+ then return (ds_binds, rules_for_imps')
+ else simpleOptPgm dflags ds_binds rules_for_imps'
+ -- The simpleOptPgm gets rid of type
+ -- bindings plus any stupid dead code
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds'
+
+ ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
- ; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
+ ; (ds_binds, ds_rules_for_imps, ds_vects)
+ <- simpleOptPgm dflags final_pgm rules_for_imps vects0
+ -- The simpleOptPgm gets rid of type
+ -- bindings plus any stupid dead code
+
+ ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env
- ; deps <- mkDependencies tcg_env
+ ; deps <- mkDependencies tcg_env
; let mod_guts = ModGuts {
mg_module = mod,
mg_inst_env = inst_env,
mg_fam_inst_env = fam_inst_env,
mg_rules = ds_rules_for_imps,
- mg_binds = ds_binds,
+ mg_binds = ds_binds',
mg_foreign = ds_fords,
mg_hpc_info = ds_hpc_info,
mg_modBreaks = modBreaks,
\begin{code}
dsVect :: LVectDecl Id -> DsM CoreVect
- dsVect (L loc (HsVect v rhs))
+ dsVect (L loc (HsVect (L _ v) rhs))
= putSrcSpanDs loc $
do { rhs' <- fmapMaybeM dsLExpr rhs
- ; return $ Vect (unLoc v) rhs'
+ ; return $ Vect v rhs'
}
- -- dsVect (L loc (HsVect v Nothing))
- -- = return $ Vect v Nothing
- -- dsVect (L loc (HsVect v (Just rhs)))
- -- = putSrcSpanDs loc $
- -- do { rhs' <- dsLExpr rhs
- -- ; return $ Vect v (Just rhs')
- -- }
+ dsVect (L _loc (HsNoVect (L _ v)))
+ = return $ NoVect v
\end{code}
+
+
+
+\begin{code}
+--
+-- Simplification routines run before the flattener. We can't use
+-- simpleOptPgm -- it doesn't preserve the order of subexpressions or
+-- let-binding groups.
+--
+simplify :: Expr CoreBndr -> Expr CoreBndr
+simplify (Var v) = Var v
+simplify (App e1 e2) = App (simplify e1) (simplify e2)
+simplify (Lit lit) = Lit lit
+simplify (Note note e) = Note note (simplify e)
+simplify (Cast e co) = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co)
+ then simplify e
+ else Cast (simplify e) co
+simplify (Lam v e) = Lam v (simplify e)
+simplify (Case e b ty as) = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
+simplify (Let bind body) = foldr Let (simplify body) (simplifyBind bind)
+simplify (Type t) = Type t
+simplify (Coercion co) = Coercion co
+
+simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
+simplifyBind (NonRec b e) = [NonRec b (simplify e)]
+simplifyBind (Rec []) = []
+simplifyBind (Rec (rbs@((b,e):rbs'))) =
+ if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
+ then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
+ else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
+
+simplifyBinds = concatMap simplifyBind
+\end{code}
CLabel
Cmm
CmmBuildInfoTables
- CmmCPS
+ CmmPipeline
CmmCallConv
CmmCommonBlockElim
CmmContFlowOpt
CmmParse
CmmProcPoint
CmmSpillReload
+ CmmRewriteAssignments
CmmStackLayout
CmmType
CmmUtils
CoreTidy
CoreUnfold
CoreUtils
+ CoqPass
ExternalCore
MkCore
MkExternalCore
hsTyVarKind, hsTyVarNameKind,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy, splitHsFunType,
+ splitHsAppTys, mkHsAppTys,
-- Type place holder
PostTcType, placeHolderType, PostTcKind, placeHolderKind,
| HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:]
+ | HsModalBoxType name (LHsType name) -- modal types; first argument is the environment classifier
+
| HsTupleTy Boxity
[LHsType name] -- Element types (length gives arity)
\begin{code}
+ splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
+ splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
+ splitHsAppTys f as = (f,as)
+
+ mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
+ mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
+ mkHsAppTys fun_ty (arg_ty:arg_tys)
+ = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
+ where
+ mk_app fun arg = HsAppTy (noLoc fun) arg
+ -- Add noLocs for inner nodes of the application;
+ -- they are never used
+
splitHsInstDeclTy
:: OutputableBndr name
=> HsType name
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty _ (HsModalBoxType ecn ty) = ppr_modalBoxType (ppr ecn) (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPredTy pred) = ppr pred
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
--------------------------
pabrackets :: SDoc -> SDoc
pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
+
+ppr_modalBoxType :: SDoc -> SDoc -> SDoc
+ppr_modalBoxType ecn p = ptext (sLit "<[") <> p <> ptext (sLit "]>@") <> ecn
+
\end{code}
-- to avoid re-building it in various places. So we build the OccName
-- when de-serialising.
+-- NOTE regarding HetMet extensions: this screws up Adam's heinous
+-- hide-the-syntactical-level-in-the-namespace trick.
+
instance Binary IfaceDecl where
put_ bh (IfaceId name ty details idinfo) = do
putByte bh 0
put_ bh (occNameFS name)
+ put_ bh (getOccNameDepth name)
put_ bh ty
put_ bh details
put_ bh idinfo
h <- getByte bh
case h of
0 -> do name <- get bh
+ depth <- get bh
ty <- get bh
details <- get bh
idinfo <- get bh
- occ <- return $! mkOccNameFS varName name
+ occ <- return $! mkOccNameFS (varNameDepth depth) name
return (IfaceId occ ty details idinfo)
1 -> error "Binary.get(TyClDecl): ForeignType"
2 -> do
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
put_ bh (occNameFS n)
+ put_ bh (getOccNameDepth n)
put_ bh def
put_ bh ty
get bh = do
n <- get bh
+ depth <- get bh
def <- get bh
ty <- get bh
- occ <- return $! mkOccNameFS varName n
+ occ <- return $! mkOccNameFS (varNameDepth depth) n
return (IfaceClassOp occ def ty)
instance Binary IfaceRule where
return (ModuleTarget a)
instance Binary IfaceVectInfo where
- put_ bh (IfaceVectInfo a1 a2 a3) = do
+ put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
put_ bh a1
put_ bh a2
put_ bh a3
+ put_ bh a4
+ put_ bh a5
get bh = do
a1 <- get bh
a2 <- get bh
a3 <- get bh
- return (IfaceVectInfo a1 a2 a3)
+ a4 <- get bh
+ a5 <- get bh
+ return (IfaceVectInfo a1 a2 a3 a4 a5)
import TyCon
import DataCon
import TysWiredIn
- import TysPrim ( anyTyConOfKind )
- import BasicTypes ( Arity, nonRuleLoopBreaker )
+ import TysPrim ( anyTyConOfKind )
+ import BasicTypes ( Arity, nonRuleLoopBreaker )
import qualified Var
import VarEnv
+ import VarSet
import Name
import NameEnv
- import OccurAnal ( occurAnalyseExpr )
- import Demand ( isBottomingSig )
+ import NameSet
+ import OccurAnal ( occurAnalyseExpr )
+ import Demand ( isBottomingSig )
import Module
import UniqFM
import UniqSupply
where
nd_doc = ptext (sLit "Need decl for") <+> ppr name
not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+>
- pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
+ pprNameSpace (occNameSpace (nameOccName name)) <+> (ppr (nameOccName name)))
2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")])
\end{code}
%************************************************************************
- %* *
- Vectorisation information
- %* *
+ %* *
+ Vectorisation information
+ %* *
%************************************************************************
\begin{code}
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceVectInfo mod typeEnv (IfaceVectInfo
- { ifaceVectInfoVar = vars
- , ifaceVectInfoTyCon = tycons
- , ifaceVectInfoTyConReuse = tyconsReuse
+ { ifaceVectInfoVar = vars
+ , ifaceVectInfoTyCon = tycons
+ , ifaceVectInfoTyConReuse = tyconsReuse
+ , ifaceVectInfoScalarVars = scalarVars
+ , ifaceVectInfoScalarTyCons = scalarTyCons
})
= do { vVars <- mapM vectVarMapping vars
; tyConRes1 <- mapM vectTyConMapping tycons
; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse
; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2)
; return $ VectInfo
- { vectInfoVar = mkVarEnv vVars
- , vectInfoTyCon = mkNameEnv vTyCons
- , vectInfoDataCon = mkNameEnv (concat vDataCons)
- , vectInfoPADFun = mkNameEnv vPAs
- , vectInfoIso = mkNameEnv vIsos
+ { vectInfoVar = mkVarEnv vVars
+ , vectInfoTyCon = mkNameEnv vTyCons
+ , vectInfoDataCon = mkNameEnv (concat vDataCons)
+ , vectInfoPADFun = mkNameEnv vPAs
+ , vectInfoIso = mkNameEnv vIsos
+ , vectInfoScalarVars = mkVarSet (map lookupVar scalarVars)
+ , vectInfoScalarTyCons = mkNameSet scalarTyCons
}
}
where
\end{code}
%************************************************************************
- %* *
- Types
- %* *
+ %* *
+ Types
+ %* *
%************************************************************************
\begin{code}
| Opt_DoCmmLinting
| Opt_DoAsmLinting
+ | Opt_F_coqpass -- run the core-to-core coqPass, but don't change anything (just "parse/unparse")
+ | Opt_F_skolemize -- run the core-to-core coqPass, skolemizing the proof
+ | Opt_F_flatten -- run the core-to-core coqPass, flattening the proof
+ | Opt_F_simpleopt_before_flatten -- run the "simplPgmOpt" before the coqPass
+ | Opt_D_dump_proofs -- dump natural deduction typing proof of the coqpass input
+ | Opt_D_coqpass -- run the core-to-string coqPass and dumps the result
+
| Opt_WarnIsError -- -Werror; makes warnings fatal
| Opt_WarnDuplicateExports
| Opt_WarnHiShadows
| Opt_GHCForeignImportPrim
| Opt_ParallelArrays -- Syntactic support for parallel arrays
| Opt_Arrows -- Arrow-notation syntax
+ | Opt_ModalTypes -- Heterogeneous Metaprogramming (modal types, brackets, escape, CSP)
| Opt_TemplateHaskell
| Opt_QuasiQuotes
| Opt_ImplicitParams
= HscC -- ^ Generate C code.
| HscAsm -- ^ Generate assembly using the native code generator.
| HscLlvm -- ^ Generate assembly using the llvm code generator.
- | HscJava -- ^ Generate Java bytecode.
| HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory')
| HscNothing -- ^ Don't generate any code. See notes above.
deriving (Eq, Show)
showHscTargetFlag HscC = "-fvia-c"
showHscTargetFlag HscAsm = "-fasm"
showHscTargetFlag HscLlvm = "-fllvm"
- showHscTargetFlag HscJava = panic "No flag for HscJava"
showHscTargetFlag HscInterpreted = "-fbyte-code"
showHscTargetFlag HscNothing = "-fno-code"
setVerbosity (Just 2)))
, Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats))
+ ------ Coq-in-GHC ---------------------------
+ , Flag "ddump-proofs" (NoArg (setDynFlag Opt_D_dump_proofs))
+ , Flag "ddump-coqpass" (NoArg (setDynFlag Opt_D_coqpass))
+ , Flag "fcoqpass" (NoArg (setDynFlag Opt_F_coqpass))
+ , Flag "fsimpleopt-before-flatten" (NoArg (setDynFlag Opt_F_simpleopt_before_flatten))
+ , Flag "fflatten" (NoArg (do { setDynFlag Opt_F_coqpass ; setDynFlag Opt_F_flatten }))
+ , Flag "funsafe-skolemize" (NoArg (do { setDynFlag Opt_F_coqpass ; setDynFlag Opt_F_flatten ; setDynFlag Opt_F_skolemize }))
+
------ Machine dependant (-m<blah>) stuff ---------------------------
, Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release"))
deprecatedForExtension "DoRec"),
( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword
( "Arrows", Opt_Arrows, nop ),
+ ( "ModalTypes", Opt_ModalTypes, nop ),
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
( "QuasiQuotes", Opt_QuasiQuotes, nop ),
, (Opt_FlexibleInstances, turnOn, Opt_TypeSynonymInstances)
, (Opt_FunctionalDependencies, turnOn, Opt_MultiParamTypeClasses)
+ , (Opt_ModalTypes, turnOn, Opt_RankNTypes)
+ , (Opt_ModalTypes, turnOn, Opt_ExplicitForAll)
+ --, (Opt_ModalTypes, turnOn, Opt_RebindableSyntax)
+ , (Opt_ModalTypes, turnOff, Opt_MonomorphismRestriction)
+
, (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off!
, (Opt_GADTs, turnOn, Opt_GADTSyntax)
-- definition, with some hand-coded bits.
--
-- Completely accurate information about token-spans within the source
- -- file is maintained. Every token has a start and end SrcLoc attached to it.
+ -- file is maintained. Every token has a start and end RealSrcLoc
+ -- attached to it.
--
-----------------------------------------------------------------------------
getLexState, popLexState, pushLexState,
extension, bangPatEnabled, datatypeContextsEnabled,
addWarning,
+ incrBracketDepth, decrBracketDepth, getParserBrakDepth,
lexTokenStream
) where
}
<0> {
+ "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol }
+ { special ITopenBrak }
+ "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak }
+ "~~" / { ifExtension hetMetEnabled } { special ITescape }
+ "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent }
+ "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar }
+}
+
+<0> {
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
}
| ITlanguage_prag
| ITvect_prag
| ITvect_scalar_prag
+ | ITnovect_prag
| ITdotdot -- reserved symbols
| ITcolon
| ITparenEscape -- $(
| ITvarQuote -- '
| ITtyQuote -- ''
- | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|]
+ | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|]
-- Arrow notation extension
| ITproc
| ITLarrowtail -- -<<
| ITRarrowtail -- >>-
+ -- Heterogeneous Metaprogramming extension
+ | ITopenBrak -- <[
+ | ITcloseBrak -- ]>
+ | ITescape -- ~~
+ | ITescapeDollar -- ~~$
+ | ITdoublePercent -- %%
+
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
-- -----------------------------------------------------------------------------
-- Lexer actions
- type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
+ type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
special :: Token -> Action
special tok span _buf _len = return (L span tok)
Layout prev_off : _ -> prev_off < offset
_ -> True
if isOK then pop_and open_brace span buf len
- else failSpanMsgP span (text "Missing block")
+ else failSpanMsgP (RealSrcSpan span) (text "Missing block")
pop_and :: Action -> Action
pop_and act span buf len = do _ <- popLexState
nested comments require traversing by hand, they can't be parsed
using regular expressions.
-}
- nested_comment :: P (Located Token) -> Action
+ nested_comment :: P (RealLocated Token) -> Action
nested_comment cont span _str _len = do
input <- getInput
go "" (1::Int) input
Just (_,_) -> go ('\123':commentAcc) input docType False
Just (c,input) -> go (c:commentAcc) input docType False
- withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token))
- -> P (Located Token)
+ withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
+ -> P (RealLocated Token)
withLexedDocType lexDocComment = do
input@(AI _ buf) <- getInput
case prevChar buf ' ' of
-- called afterwards, so it can just update the state.
docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
- SrcSpan -> P (Located Token)
+ RealSrcSpan -> P (RealLocated Token)
docCommentEnd input commentAcc docType buf span = do
setInput input
let (AI loc nextBuf) = input
comment = reverse commentAcc
- span' = mkSrcSpan (srcSpanStart span) loc
+ span' = mkRealSrcSpan (realSrcSpanStart span) loc
last_len = byteDiff buf nextBuf
span `seq` setLastToken span' last_len
return (L span' (docType comment))
- errBrace :: AlexInput -> SrcSpan -> P a
- errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
+ errBrace :: AlexInput -> RealSrcSpan -> P a
+ errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
open_brace, close_brace :: Action
open_brace span _str _len = do
varsym = sym ITvarsym
consym = sym ITconsym
- sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int
- -> P (Located Token)
+ sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
+ -> P (RealLocated Token)
sym con span buf len =
case lookupUFM reservedSymsFM fs of
Just (keyword,exts) -> do
setLine :: Int -> Action
setLine code span buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
- setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+ setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-- subtract one: the line number refers to the *following* line
_ <- popLexState
pushLexState code
setFile :: Int -> Action
setFile code span buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
- setAlrLastLoc noSrcSpan
- setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+ setAlrLastLoc $ alrInitialLoc file
+ setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
_ <- popLexState
pushLexState code
lexToken
+ alrInitialLoc :: FastString -> RealSrcSpan
+ alrInitialLoc file = mkRealSrcSpan loc loc
+ where -- This is a hack to ensure that the first line in a file
+ -- looks like it is after the initial location:
+ loc = mkRealSrcLoc file (-1) (-1)
-- -----------------------------------------------------------------------------
-- Options, includes and language pragmas.
start <- getSrcLoc
tok <- go [] input
end <- getSrcLoc
- return (L (mkSrcSpan start end) tok)
+ return (L (mkRealSrcSpan start end) tok)
where go acc input
= if isString input "#-}"
then do setInput input
= case alexGetChar i of
Just (c,i') | c == x -> isString i' xs
_other -> False
- err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
+ err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
-- -----------------------------------------------------------------------------
lex_string_tok span _buf _len = do
tok <- lex_string ""
end <- getSrcLoc
- return (L (mkSrcSpan (srcSpanStart span) end) tok)
+ return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok)
lex_string :: String -> P Token
lex_string s = do
-- see if there's a trailing quote
lex_char_tok span _buf _len = do -- We've seen '
i1 <- getInput -- Look ahead to first character
- let loc = srcSpanStart span
+ let loc = realSrcSpanStart span
case alexGetChar' i1 of
Nothing -> lit_error i1
th_exts <- extension thEnabled
if th_exts then do
setInput i2
- return (L (mkSrcSpan loc end2) ITtyQuote)
+ return (L (mkRealSrcSpan loc end2) ITtyQuote)
else lit_error i1
Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash
-- If TH is on, just parse the quote only
th_exts <- extension thEnabled
let (AI end _) = i1
- if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
+ if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote)
else lit_error i2
- finish_char_tok :: SrcLoc -> Char -> P (Located Token)
+ finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token)
finish_char_tok loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
= do magicHash <- extension magicHashEnabled
case alexGetChar' i of
Just ('#',i@(AI end _)) -> do
setInput i
- return (L (mkSrcSpan loc end) (ITprimchar ch))
+ return (L (mkRealSrcSpan loc end) (ITprimchar ch))
_other ->
- return (L (mkSrcSpan loc end) (ITchar ch))
+ return (L (mkRealSrcSpan loc end) (ITchar ch))
else do
- return (L (mkSrcSpan loc end) (ITchar ch))
+ return (L (mkRealSrcSpan loc end) (ITchar ch))
isAny :: Char -> Bool
isAny c | c > '\x7f' = isPrint c
quoteStart <- getSrcLoc
quote <- lex_quasiquote ""
end <- getSrcLoc
- return (L (mkSrcSpan (srcSpanStart span) end)
+ return (L (mkRealSrcSpan (realSrcSpanStart span) end)
(ITquasiQuote (mkFastString quoter,
mkFastString (reverse quote),
- mkSrcSpan quoteStart end)))
+ mkRealSrcSpan quoteStart end)))
lex_quasiquote :: String -> P String
lex_quasiquote s = do
warn :: DynFlag -> SDoc -> Action
warn option warning srcspan _buf _len = do
- addWarning option srcspan warning
+ addWarning option (RealSrcSpan srcspan) warning
lexToken
warnThen :: DynFlag -> SDoc -> Action -> Action
warnThen option warning action srcspan buf len = do
- addWarning option srcspan warning
+ addWarning option (RealSrcSpan srcspan) warning
action srcspan buf len
-- -----------------------------------------------------------------------------
buffer :: StringBuffer,
dflags :: DynFlags,
messages :: Messages,
- last_loc :: SrcSpan, -- pos of previous token
+ last_loc :: RealSrcSpan, -- pos of previous token
last_len :: !Int, -- len of previous token
- loc :: SrcLoc, -- current loc (end of prev token + 1)
+ loc :: RealSrcLoc, -- current loc (end of prev token + 1)
extsBitmap :: !Int, -- bitmap that determines permitted extensions
context :: [LayoutContext],
lex_state :: [Int],
-- Used in the alternative layout rule:
-- These tokens are the next ones to be sent out. They are
-- just blindly emitted, without the rule looking at them again:
- alr_pending_implicit_tokens :: [Located Token],
+ alr_pending_implicit_tokens :: [RealLocated Token],
-- This is the next token to be considered or, if it is Nothing,
-- we need to get the next token from the input stream:
- alr_next_token :: Maybe (Located Token),
+ alr_next_token :: Maybe (RealLocated Token),
-- This is what we consider to be the locatino of the last token
-- emitted:
- alr_last_loc :: SrcSpan,
+ alr_last_loc :: RealSrcSpan,
-- The stack of layout contexts:
alr_context :: [ALRContext],
-- Are we expecting a '{'? If it's Just, then the ALRLayout tells
alr_expecting_ocurly :: Maybe ALRLayout,
-- Have we just had the '}' for a let block? If so, than an 'in'
-- token doesn't need to close anything:
- alr_justClosedExplicitLetBlock :: Bool
+ alr_justClosedExplicitLetBlock :: Bool,
+ code_type_bracket_depth :: Int
}
-- last_loc and last_len are used when generating error messages,
-- and in pushCurrentContext only. Sigh, if only Happy passed the
PFailed span err -> PFailed span err
failP :: String -> P a
- failP msg = P $ \s -> PFailed (last_loc s) (text msg)
+ failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
failMsgP :: String -> P a
- failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
+ failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
- failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
- failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
+ failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
+ failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
failSpanMsgP :: SrcSpan -> SDoc -> P a
failSpanMsgP span msg = P $ \_ -> PFailed span msg
setExts :: (Int -> Int) -> P ()
setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
- setSrcLoc :: SrcLoc -> P ()
+ setSrcLoc :: RealSrcLoc -> P ()
setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
+incrBracketDepth :: P ()
+incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)+1}) ()
+decrBracketDepth :: P ()
+decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)-1}) ()
+getParserBrakDepth :: P Int
+getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s)
+
- getSrcLoc :: P SrcLoc
+ getSrcLoc :: P RealSrcLoc
getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
- setLastToken :: SrcSpan -> Int -> P ()
+ setLastToken :: RealSrcSpan -> Int -> P ()
setLastToken loc len = P $ \s -> POk s {
last_loc=loc,
last_len=len
} ()
- data AlexInput = AI SrcLoc StringBuffer
+ data AlexInput = AI RealSrcLoc StringBuffer
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (AI _ buf) = prevChar buf '\n'
getLexState :: P Int
getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
- popNextToken :: P (Maybe (Located Token))
+ popNextToken :: P (Maybe (RealLocated Token))
popNextToken
= P $ \s@PState{ alr_next_token = m } ->
POk (s {alr_next_token = Nothing}) m
([],Nothing) -> return impt
_other -> return True
- setAlrLastLoc :: SrcSpan -> P ()
+ setAlrLastLoc :: RealSrcSpan -> P ()
setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
- getAlrLastLoc :: P SrcSpan
+ getAlrLastLoc :: P RealSrcSpan
getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
getALRContext :: P [ALRContext]
setJustClosedExplicitLetBlock b
= P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
- setNextToken :: Located Token -> P ()
+ setNextToken :: RealLocated Token -> P ()
setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
implicitTokenPending :: P Bool
[] -> POk s False
_ -> POk s True
- popPendingImplicitToken :: P (Maybe (Located Token))
+ popPendingImplicitToken :: P (Maybe (RealLocated Token))
popPendingImplicitToken
= P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
case ts of
[] -> POk s Nothing
(t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
- setPendingImplicitTokens :: [Located Token] -> P ()
+ setPendingImplicitTokens :: [RealLocated Token] -> P ()
setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
getAlrExpectingOCurly :: P (Maybe ALRLayout)
relaxedLayoutBit = 24
nondecreasingIndentationBit :: Int
nondecreasingIndentationBit = 25
+hetMetBit :: Int
+hetMetBit = 31
always :: Int -> Bool
always _ = True
parrEnabled flags = testBit flags parrBit
arrowsEnabled :: Int -> Bool
arrowsEnabled flags = testBit flags arrowsBit
+hetMetEnabled :: Int -> Bool
+hetMetEnabled flags = testBit flags hetMetBit
thEnabled :: Int -> Bool
thEnabled flags = testBit flags thBit
ipEnabled :: Int -> Bool
-- PState for parsing options pragmas
--
- pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+ pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
pragState dynflags buf loc = (mkPState dynflags buf loc) {
lex_state = [bol, option_prags, 0]
}
-- create a parse state
--
- mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+ mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState flags buf loc =
PState {
buffer = buf,
dflags = flags,
messages = emptyMessages,
- last_loc = mkSrcSpan loc loc,
+ last_loc = mkRealSrcSpan loc loc,
last_len = 0,
loc = loc,
extsBitmap = fromIntegral bitmap,
lex_state = [bol, 0],
alr_pending_implicit_tokens = [],
alr_next_token = Nothing,
- alr_last_loc = noSrcSpan,
+ alr_last_loc = alrInitialLoc (fsLit "<no file>"),
alr_context = [],
alr_expecting_ocurly = Nothing,
- alr_justClosedExplicitLetBlock = False
+ alr_justClosedExplicitLetBlock = False,
+ code_type_bracket_depth = 0
}
where
bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
.|. arrowsBit `setBitIf` xopt Opt_Arrows flags
+ .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags
.|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
.|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
.|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
last_len = len, last_loc = last_loc }) ->
case ctx of
(_:tl) -> POk s{ context = tl } ()
- [] -> PFailed last_loc (srcParseErr buf len)
+ [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
-- Push a new layout context at the indentation of the last token read.
-- This is only used at the outer level of a module when the 'module'
srcParseFail :: P a
srcParseFail = P $ \PState{ buffer = buf, last_len = len,
last_loc = last_loc } ->
- PFailed last_loc (srcParseErr buf len)
+ PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
-- A lexical error is reported at a particular position in the source file,
-- not over a token range.
lexer cont = do
alr <- extension alternativeLayoutRule
let lexTokenFun = if alr then lexTokenAlr else lexToken
- tok@(L _span _tok__) <- lexTokenFun
- --trace ("token: " ++ show _tok__) $ do
- cont tok
+ (L span tok) <- lexTokenFun
+ --trace ("token: " ++ show tok) $ do
+ cont (L (RealSrcSpan span) tok)
- lexTokenAlr :: P (Located Token)
+ lexTokenAlr :: P (RealLocated Token)
lexTokenAlr = do mPending <- popPendingImplicitToken
t <- case mPending of
Nothing ->
_ -> return ()
return t
- alternativeLayoutRuleToken :: Located Token -> P (Located Token)
+ alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
alternativeLayoutRuleToken t
= do context <- getALRContext
lastLoc <- getAlrLastLoc
let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
thisLoc = getLoc t
thisCol = srcSpanStartCol thisLoc
- newLine = (lastLoc == noSrcSpan)
- || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc)
+ newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
case (unLoc t, context, mExpectingOCurly) of
-- This case handles a GHC extension to the original H98
-- layout rule...
(ITwhere, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- thisLoc
+ (RealSrcSpan thisLoc)
(transitionalAlternativeLayoutWarning
"`where' clause at the same depth as implicit layout block")
setALRContext ls
(ITvbar, ALRLayout _ col : ls, _)
| newLine && thisCol == col && transitional ->
do addWarning Opt_WarnAlternativeLayoutRuleTransitional
- thisLoc
+ (RealSrcSpan thisLoc)
(transitionalAlternativeLayoutWarning
"`|' at the same depth as implicit layout block")
setALRContext ls
topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
- lexToken :: P (Located Token)
+ lexToken :: P (RealLocated Token)
lexToken = do
inp@(AI loc1 buf) <- getInput
sc <- getLexState
exts <- getExts
case alexScanUser exts inp sc of
AlexEOF -> do
- let span = mkSrcSpan loc1 loc1
+ let span = mkRealSrcSpan loc1 loc1
setLastToken span 0
return (L span ITeof)
AlexError (AI loc2 buf) ->
lexToken
AlexToken inp2@(AI end buf2) _ t -> do
setInput inp2
- let span = mkSrcSpan loc1 end
+ let span = mkRealSrcSpan loc1 end
let bytes = byteDiff buf buf2
span `seq` setLastToken span bytes
t span buf bytes
- reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a
+ reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
reportLexError loc1 loc2 buf str
| atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
| otherwise =
then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
- lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token]
+ lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
lexTokenStream buf loc dflags = unP go initState
where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
initState = mkPState dflags' buf loc
("core", token ITcore_prag),
("unpack", token ITunpack_prag),
("ann", token ITann_prag),
- ("vectorize", token ITvect_prag)])
+ ("vectorize", token ITvect_prag),
+ ("novectorize", token ITnovect_prag)])
twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
("notinline conlike", token (ITinline_prag NoInline ConLike)),
"noinline" -> "notinline"
"specialise" -> "specialize"
"vectorise" -> "vectorize"
+ "novectorise" -> "novectorize"
"constructorlike" -> "conlike"
_ -> prag'
canon_ws s = unwords (map canonical (words s))
import ForeignCall ( Safety(..), CExportSpec(..), CLabelString,
CCallConv(..), CCallTarget(..), defaultCCallConv
)
-import OccName ( varName, dataName, tcClsName, tvName )
+import OccName ( varName, varNameDepth, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
- import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
- SrcSpan, combineLocs, srcLocFile,
- mkSrcLoc, mkSrcSpan )
+ import SrcLoc
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, liftedTypeKind, unliftedTypeKind )
'by' { L _ ITby } -- for list transform extension
'using' { L _ ITusing } -- for list transform extension
- '{-# INLINE' { L _ (ITinline_prag _ _) }
- '{-# SPECIALISE' { L _ ITspec_prag }
+ '{-# INLINE' { L _ (ITinline_prag _ _) }
+ '{-# SPECIALISE' { L _ ITspec_prag }
'{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) }
- '{-# SOURCE' { L _ ITsource_prag }
- '{-# RULES' { L _ ITrules_prag }
- '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
- '{-# SCC' { L _ ITscc_prag }
- '{-# GENERATED' { L _ ITgenerated_prag }
- '{-# DEPRECATED' { L _ ITdeprecated_prag }
- '{-# WARNING' { L _ ITwarning_prag }
- '{-# UNPACK' { L _ ITunpack_prag }
- '{-# ANN' { L _ ITann_prag }
+ '{-# SOURCE' { L _ ITsource_prag }
+ '{-# RULES' { L _ ITrules_prag }
+ '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
+ '{-# SCC' { L _ ITscc_prag }
+ '{-# GENERATED' { L _ ITgenerated_prag }
+ '{-# DEPRECATED' { L _ ITdeprecated_prag }
+ '{-# WARNING' { L _ ITwarning_prag }
+ '{-# UNPACK' { L _ ITunpack_prag }
+ '{-# ANN' { L _ ITann_prag }
'{-# VECTORISE' { L _ ITvect_prag }
'{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag }
- '#-}' { L _ ITclose_prag }
+ '{-# NOVECTORISE' { L _ ITnovect_prag }
+ '#-}' { L _ ITclose_prag }
'..' { L _ ITdotdot } -- reserved symbols
':' { L _ ITcolon }
'#)' { L _ ITcubxparen }
'(|' { L _ IToparenbar }
'|)' { L _ ITcparenbar }
+ '<[' { L _ ITopenBrak }
+ ']>' { L _ ITcloseBrak }
+ '~~' { L _ ITescape }
+ '~~$' { L _ ITescapeDollar }
+ '%%' { L _ ITdoublePercent }
';' { L _ ITsemi }
',' { L _ ITcomma }
'`' { L _ ITbackquote }
| oqtycon '(' ')' { LL (IEThingWith (unLoc $1) []) }
| oqtycon '(' qcnames ')' { LL (IEThingWith (unLoc $1) (reverse $3)) }
| 'module' modid { LL (IEModuleContents (unLoc $2)) }
-
+ | '<[' incdepth export decdepth ']>' { $3 }
qcnames :: { [RdrName] }
: qcnames ',' qcname_ext { unLoc $3 : $1 }
| qcname_ext { [unLoc $1] }
-- Top-Level Declarations
topdecls :: { OrdList (LHsDecl RdrName) }
- : topdecls ';' topdecl { $1 `appOL` $3 }
- | topdecls ';' { $1 }
- | topdecl { $1 }
+ : topdecls ';' topdecl { $1 `appOL` $3 }
+ | topdecls ';' { $1 }
+ | topdecl { $1 }
topdecl :: { OrdList (LHsDecl RdrName) }
- : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
- | ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
- | 'instance' inst_type where_inst
- { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
- in
- unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
+ : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ | ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ | 'instance' inst_type where_inst
+ { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
+ in
+ unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
- | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
- | 'foreign' fdecl { unitOL (LL (unLoc $2)) }
+ | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
+ | 'foreign' fdecl { unitOL (LL (unLoc $2)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# WARNING' warnings '#-}' { $2 }
- | '{-# RULES' rules '#-}' { $2 }
- | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) }
- | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) }
- | annotation { unitOL $1 }
- | decl { unLoc $1 }
-
- -- Template Haskell Extension
- -- The $(..) form is one possible form of infixexp
- -- but we treat an arbitrary expression just as if
- -- it had a $(..) wrapped around it
- | infixexp { unitOL (LL $ mkTopSpliceDecl $1) }
+ | '{-# RULES' rules '#-}' { $2 }
+ | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) }
+ | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) }
+ | '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) }
+ | annotation { unitOL $1 }
+ | decl { unLoc $1 }
+
+ -- Template Haskell Extension
+ -- The $(..) form is one possible form of infixexp
+ -- but we treat an arbitrary expression just as if
+ -- it had a $(..) wrapped around it
+ | infixexp { unitOL (LL $ mkTopSpliceDecl $1) }
-- Type classes
--
| '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 }
| '[' ctype ']' { LL $ HsListTy $2 }
+ | '<[' ctype ']>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 }
| '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) }
| infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3;
let { l = comb2 $1 $> };
return $! (sL l (unitOL $! (sL l $ ValD r))) } }
+
| docdecl { LL $ unitOL $1 }
rhs :: { Located (GRHSs RdrName) }
: TH_QUASIQUOTE { let { loc = getLoc $1
; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkUnqual varName quoter }
- in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
+ in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
+incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } }
+decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } }
+
+
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
| infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
| infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
| infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
| infixexp { $1 }
+ | '~~$' decdepth exp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) }
infixexp :: { LHsExpr RdrName }
: exp10 { $1 }
-- arrow notation extension
| '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) }
+ -- code type notation extension
+ | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) }
+ | '~~' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) }
+ | '%%' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetCSP placeHolderType $3) }
+
cmdargs :: { [LHsCmdTop RdrName] }
: cmdargs acmd { $2 : $1 }
| {- empty -} { [] }
| PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
varid :: { Located RdrName }
- : VARID { L1 $! mkUnqual varName (getVARID $1) }
+ : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual varName (fsLit "safe") }
| '-' { L1 $ mkUnqual varName (fsLit "-") }
varsym_no_minus :: { Located RdrName } -- varsym not including '-'
- : VARSYM { L1 $ mkUnqual varName (getVARSYM $1) }
- | special_sym { L1 $ mkUnqual varName (unLoc $1) }
-
+ : VARSYM {% do { depth <- getParserBrakDepth
+ ; return (L1 $! mkUnqual (varNameDepth depth) (getVARSYM $1)) } }
+ | special_sym {% do { depth <- getParserBrakDepth
+ ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } }
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
-- Other classes
randomClassName, randomGenClassName, monadPlusClassName,
+ -- Code types
+ hetmet_brak_name, hetmet_esc_name, hetmet_csp_name, hetmet_flatten_name, hetmet_unflatten_name, hetmet_flattened_id_name,
+ hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name,
+ hetmet_guest_char_literal_name,
+ hetmet_PGArrow_name,
+ hetmet_PGArrow_unit_name,
+ hetmet_PGArrow_tensor_name,
+ hetmet_PGArrow_exponent_name,
+ hetmet_pga_id_name,
+ hetmet_pga_comp_name,
+ hetmet_pga_first_name,
+ hetmet_pga_second_name,
+ hetmet_pga_cancell_name,
+ hetmet_pga_cancelr_name,
+ hetmet_pga_uncancell_name,
+ hetmet_pga_uncancelr_name,
+ hetmet_pga_assoc_name,
+ hetmet_pga_unassoc_name,
+ hetmet_pga_copy_name,
+ hetmet_pga_drop_name,
+ hetmet_pga_swap_name,
+ hetmet_pga_applyl_name,
+ hetmet_pga_applyr_name,
+ hetmet_pga_curryl_name,
+ hetmet_pga_curryr_name,
+ hetmet_pga_loopl_name,
+ hetmet_pga_loopr_name,
+
-- Annotation type checking
toAnnotationWrapperName
gHC_MAGIC,
gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST,
+ gHC_HETMET_CODETYPES,
+ gHC_HETMET_PRIVATE,
+ gHC_HETMET_GARROW,
gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
- gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
- gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,
+ gHC_CONC, gHC_IO, gHC_IO_Exception,
+ gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS,
dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP,
aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
gHC_NUM = mkBaseModule (fsLit "GHC.Num")
gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer")
gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")
+gHC_HETMET_CODETYPES = mkBaseModule (fsLit "GHC.HetMet.CodeTypes")
+gHC_HETMET_PRIVATE = mkBaseModule (fsLit "GHC.HetMet.Private")
+gHC_HETMET_GARROW = mkBaseModule (fsLit "GHC.HetMet.GArrow")
gHC_LIST = mkBaseModule (fsLit "GHC.List")
gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple")
dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple")
dATA_STRING = mkBaseModule (fsLit "Data.String")
dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable")
dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
- gHC_PACK = mkBaseModule (fsLit "GHC.Pack")
gHC_CONC = mkBaseModule (fsLit "GHC.Conc")
gHC_IO = mkBaseModule (fsLit "GHC.IO")
gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")
gHC_ST = mkBaseModule (fsLit "GHC.ST")
gHC_ARR = mkBaseModule (fsLit "GHC.Arr")
gHC_STABLE = mkBaseModule (fsLit "GHC.Stable")
- gHC_ADDR = mkBaseModule (fsLit "GHC.Addr")
gHC_PTR = mkBaseModule (fsLit "GHC.Ptr")
gHC_ERR = mkBaseModule (fsLit "GHC.Err")
gHC_REAL = mkBaseModule (fsLit "GHC.Real")
emptyPName pkg = varQual (gHC_PARR pkg) (fsLit "emptyP") emptyPIdKey
appPName pkg = varQual (gHC_PARR pkg) (fsLit "+:+") appPIdKey
+-- code type things
+hetmet_brak_name, hetmet_esc_name, hetmet_csp_name, hetmet_flatten_name, hetmet_unflatten_name, hetmet_flattened_id_name :: Name
+hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name :: Name
+hetmet_brak_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_brak") hetmet_brak_key
+hetmet_esc_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_esc") hetmet_esc_key
+hetmet_csp_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_csp") hetmet_csp_key
+hetmet_flatten_name = varQual gHC_HETMET_CODETYPES (fsLit "pga_flatten") hetmet_flatten_key
+hetmet_unflatten_name = varQual gHC_HETMET_CODETYPES (fsLit "pga_unflatten") hetmet_unflatten_key
+hetmet_flattened_id_name = varQual gHC_HETMET_CODETYPES (fsLit "pga_flattened_id") hetmet_flattened_id_key
+hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestIntegerLiteral") hetmet_guest_integer_literal_key
+hetmet_guest_string_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestStringLiteral") hetmet_guest_string_literal_key
+hetmet_guest_char_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestCharLiteral") hetmet_guest_char_literal_key
+
+hetmet_PGArrow_name :: Name
+hetmet_PGArrow_name = tcQual gHC_HETMET_PRIVATE (fsLit "PGArrow") hetmet_PGArrow_key
+hetmet_PGArrow_unit_name :: Name
+hetmet_PGArrow_unit_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowUnit") hetmet_PGArrow_unit_key
+hetmet_PGArrow_tensor_name :: Name
+hetmet_PGArrow_tensor_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowTensor") hetmet_PGArrow_tensor_key
+hetmet_PGArrow_exponent_name :: Name
+hetmet_PGArrow_exponent_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowExponent") hetmet_PGArrow_exponent_key
+hetmet_pga_id_name :: Name
+hetmet_pga_id_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_id") hetmet_pga_id_key
+hetmet_pga_comp_name :: Name
+hetmet_pga_comp_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_comp") hetmet_pga_comp_key
+hetmet_pga_first_name :: Name
+hetmet_pga_first_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_first") hetmet_pga_first_key
+hetmet_pga_second_name :: Name
+hetmet_pga_second_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_second") hetmet_pga_second_key
+hetmet_pga_cancell_name :: Name
+hetmet_pga_cancell_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_cancell") hetmet_pga_cancell_key
+hetmet_pga_cancelr_name :: Name
+hetmet_pga_cancelr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_cancelr") hetmet_pga_cancelr_key
+hetmet_pga_uncancell_name :: Name
+hetmet_pga_uncancell_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_uncancell") hetmet_pga_uncancell_key
+hetmet_pga_uncancelr_name :: Name
+hetmet_pga_uncancelr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_uncancelr") hetmet_pga_uncancelr_key
+hetmet_pga_assoc_name :: Name
+hetmet_pga_assoc_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_assoc") hetmet_pga_assoc_key
+hetmet_pga_unassoc_name :: Name
+hetmet_pga_unassoc_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_unassoc") hetmet_pga_unassoc_key
+hetmet_pga_copy_name :: Name
+hetmet_pga_copy_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_copy") hetmet_pga_copy_key
+hetmet_pga_drop_name :: Name
+hetmet_pga_drop_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_drop") hetmet_pga_drop_key
+hetmet_pga_swap_name :: Name
+hetmet_pga_swap_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_swap") hetmet_pga_swap_key
+hetmet_pga_applyl_name :: Name
+hetmet_pga_applyl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_applyl") hetmet_pga_applyl_key
+hetmet_pga_applyr_name :: Name
+hetmet_pga_applyr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_applyr") hetmet_pga_applyr_key
+hetmet_pga_curryl_name :: Name
+hetmet_pga_curryl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_curryl") hetmet_pga_curryl_key
+hetmet_pga_curryr_name :: Name
+hetmet_pga_curryr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_curryr") hetmet_pga_curryr_key
+hetmet_pga_loopl_name :: Name
+hetmet_pga_loopl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_loopl") hetmet_pga_loopl_key
+hetmet_pga_loopr_name :: Name
+hetmet_pga_loopr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_loopr") hetmet_pga_loopr_key
+
-- IO things
ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
failIOName :: Name
leftDataConKey, rightDataConKey :: Unique
leftDataConKey = mkPreludeDataConUnique 25
rightDataConKey = mkPreludeDataConUnique 26
+
+-- Data constructor for Heterogeneous Metaprogramming code types
+hetMetCodeTypeDataConKey :: Unique
+hetMetCodeTypeDataConKey = mkPreludeDataConUnique 27
\end{code}
%************************************************************************
groupMIdKey = mkPreludeMiscIdUnique 133
mzipIdKey = mkPreludeMiscIdUnique 134
+-- code types
+hetMetCodeTypeTyConKey :: Unique
+hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135
+
+hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_char_literal_key :: Unique
+hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 134
+hetmet_guest_string_literal_key = mkPreludeMiscIdUnique 135
+hetmet_guest_char_literal_key = mkPreludeMiscIdUnique 136
+hetmet_PGArrow_key :: Unique
+hetmet_PGArrow_key = mkPreludeMiscIdUnique 137
+hetmet_pga_id_key :: Unique
+hetmet_pga_id_key = mkPreludeMiscIdUnique 138
+hetmet_pga_comp_key :: Unique
+hetmet_pga_comp_key = mkPreludeMiscIdUnique 139
+hetmet_pga_first_key :: Unique
+hetmet_pga_first_key = mkPreludeMiscIdUnique 140
+hetmet_pga_second_key :: Unique
+hetmet_pga_second_key = mkPreludeMiscIdUnique 141
+hetmet_pga_cancell_key :: Unique
+hetmet_pga_cancell_key = mkPreludeMiscIdUnique 142
+hetmet_pga_cancelr_key :: Unique
+hetmet_pga_cancelr_key = mkPreludeMiscIdUnique 143
+hetmet_pga_uncancell_key :: Unique
+hetmet_pga_uncancell_key = mkPreludeMiscIdUnique 144
+hetmet_pga_uncancelr_key :: Unique
+hetmet_pga_uncancelr_key = mkPreludeMiscIdUnique 145
+hetmet_pga_assoc_key :: Unique
+hetmet_pga_assoc_key = mkPreludeMiscIdUnique 146
+hetmet_pga_unassoc_key :: Unique
+hetmet_pga_unassoc_key = mkPreludeMiscIdUnique 147
+hetmet_pga_copy_key :: Unique
+hetmet_pga_copy_key = mkPreludeMiscIdUnique 148
+hetmet_pga_drop_key :: Unique
+hetmet_pga_drop_key = mkPreludeMiscIdUnique 149
+hetmet_pga_swap_key :: Unique
+hetmet_pga_swap_key = mkPreludeMiscIdUnique 150
+hetmet_pga_applyl_key :: Unique
+hetmet_pga_applyl_key = mkPreludeMiscIdUnique 151
+hetmet_pga_applyr_key :: Unique
+hetmet_pga_applyr_key = mkPreludeMiscIdUnique 152
+hetmet_pga_curryl_key :: Unique
+hetmet_pga_curryl_key = mkPreludeMiscIdUnique 153
+hetmet_pga_curryr_key :: Unique
+hetmet_pga_curryr_key = mkPreludeMiscIdUnique 154
+hetmet_flatten_key = mkPreludeMiscIdUnique 155
+hetmet_unflatten_key = mkPreludeMiscIdUnique 156
+hetmet_flattened_id_key = mkPreludeMiscIdUnique 157
+hetmet_PGArrow_unit_key :: Unique
+hetmet_PGArrow_unit_key = mkPreludeMiscIdUnique 158
+hetmet_PGArrow_tensor_key :: Unique
+hetmet_PGArrow_tensor_key = mkPreludeMiscIdUnique 159
+hetmet_PGArrow_exponent_key :: Unique
+hetmet_PGArrow_exponent_key = mkPreludeMiscIdUnique 160
+
+hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique
+hetmet_brak_key = mkPreludeMiscIdUnique 161
+hetmet_esc_key = mkPreludeMiscIdUnique 162
+hetmet_csp_key = mkPreludeMiscIdUnique 163
+
+hetmet_pga_loopl_key :: Unique
+hetmet_pga_loopl_key = mkPreludeMiscIdUnique 164
+hetmet_pga_loopr_key :: Unique
+hetmet_pga_loopr_key = mkPreludeMiscIdUnique 165
+
---------------- Template Haskell -------------------
-- USES IdUniques 200-499
\begin{code}
numericTyKeys :: [Unique]
-numericTyKeys =
+numericTyKeys =
[ wordTyConKey
, intTyConKey
, integerTyConKey
import LoadIface ( loadInterfaceForName, loadSrcInterface )
import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName )
+import TcEnv ( getHetMetLevel )
import HsSyn
import RdrHsSyn ( extractHsTyRdrTyVars )
import RdrName
-- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
-- The latter does pickGREs, but we want to allow 'x'
-- even if only 'M.x' is in scope
- [gre] -> do { addUsedRdrNames (used_rdr_names gre)
+ [gre] -> do { addUsedRdrName gre (used_rdr_name gre)
; return (gre_name gre) }
[] -> do { addErr (unknownSubordinateErr doc rdr_name)
; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres))
gres -> do { addNameClashErrRn rdr_name gres
; return (gre_name (head gres)) } }
where
+ rdr_occ = rdrNameOcc rdr_name
+
pick NoParent gres -- Normal lookup
= pickGREs rdr_name gres
pick (ParentIs p) gres -- Disambiguating lookup
right_parent _ _ = False
-- Note [Usage for sub-bndrs]
- used_rdr_names gre
- | isQual rdr_name = [rdr_name]
+ used_rdr_name gre
+ | isQual rdr_name = rdr_name
| otherwise = case gre_prov gre of
- LocalDef -> [rdr_name]
- Imported is -> map mk_qual_rdr is
- mk_qual_rdr imp_spec = mkRdrQual (is_as (is_decl imp_spec)) rdr_occ
- rdr_occ = rdrNameOcc rdr_name
+ LocalDef -> rdr_name
+ Imported is -> used_rdr_name_from_is is
+
+ used_rdr_name_from_is imp_specs -- rdr_name is unqualified
+ | not (all (is_qual . is_decl) imp_specs)
+ = rdr_name -- An unqualified import is available
+ | otherwise
+ = -- Only qualified imports available, so make up
+ -- a suitable qualifed name from the first imp_spec
+ ASSERT( not (null imp_specs) )
+ mkRdrQual (is_as (is_decl (head imp_specs))) rdr_occ
newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
~~~~~~~~~~~~~~~~~~~~~~~~~~
If you have this
import qualified M( C( f ) )
- intance M.C T where
+ instance M.C T where
f x = x
then is the qualified import M.f used? Obviously yes.
But the RdrName used in the instance decl is unqualified. In effect,
we fill in the qualification by looking for f's whose class is M.C
But when adding to the UsedRdrNames we must make that qualification
- explicit, otherwise we get "Redundant import of M.C".
+ explicit (saying "used M.f"), otherwise we get "Redundant import of M.f".
+
+ So we make up a suitable (fake) RdrName. But be careful
+ import qualifed M
+ import M( C(f) )
+ instance C T where
+ f x = x
+ Here we want to record a use of 'f', not of 'M.f', otherwise
+ we'll miss the fact that the qualified import is redundant.
--------------------------------------------------
-- Occurrences
lookupSyntaxName :: Name -- The standard name
-> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
- = xoptM Opt_RebindableSyntax `thenM` \ rebindable_on ->
- if not rebindable_on then normal_case
- else
- -- Get the similarly named thing from the local environment
- lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
- return (HsVar usr_name, unitFV usr_name)
- where
- normal_case = return (HsVar std_name, emptyFVs)
+ = do ec <- getHetMetLevel
+ std_name' <- return $ setNameDepth (length ec) std_name
+ rebindable_on <- xoptM Opt_RebindableSyntax
+ if not rebindable_on
+ then return (HsVar std_name', emptyFVs)
+ else do usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name'))
+ return (HsVar usr_name, unitFV usr_name)
+ -- Get the similarly named thing from the local environment
lookupSyntaxTable :: [Name] -- Standard names
-> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames
where
pp_item :: (RdrName, HowInScope) -> SDoc
pp_item (rdr, Left loc) = quotes (ppr rdr) <+> -- Locally defined
- parens (ptext (sLit "line") <+> int (srcSpanStartLine loc))
+ parens (ptext (sLit "line") <+> int (srcSpanStartLine loc'))
+ where loc' = case loc of
+ UnhelpfulSpan _ ->
+ panic "unknownNameSuggestErr UnhelpfulSpan"
+ RealSrcSpan l -> l
pp_item (rdr, Right is) = quotes (ppr rdr) <+> -- Imported
parens (ptext (sLit "imported from") <+> ppr (is_mod is))
import HsSyn
import Class ( FunDep )
-import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
+import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, hetMetCodeTypeTyCon, charTyCon )
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
- import SrcLoc ( Located(..), unLoc )
+ import SrcLoc
\end{code}
%************************************************************************
charTyCon_name = getName charTyCon
listTyCon_name = getName listTyCon
parrTyCon_name = getName parrTyCon
+hetMetCodeTypeTyCon_name :: Name
+hetMetCodeTypeTyCon_name = getName hetMetCodeTypeTyCon
tupleTyCon_name :: Boxity -> Int -> Name
tupleTyCon_name boxity n = getName (tupleTyCon boxity n)
get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty
get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty
+ get (HsModalBoxType ecn ty) = (unitNameSet ecn) `unionNameSets` (unitNameSet hetMetCodeTypeTyCon_name) `unionNameSets` (getl ty)
get (HsTupleTy _ tys) = extractHsTyNames_s tys
get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
get (HsPredTy p) = extractHsPredTyNames p
= zonkLExpr env e `thenM` \new_e ->
returnM (HsPar new_e)
+zonkExpr env (HsHetMetBrak c e)
+ = do c' <- zonkTcTypeToType env c
+ e' <- zonkLExpr env e
+ return (HsHetMetBrak c' e')
+
+zonkExpr env (HsHetMetEsc c t e)
+ = do c' <- zonkTcTypeToType env c
+ t' <- zonkTcTypeToType env t
+ e' <- zonkLExpr env e
+ return (HsHetMetEsc c' t' e')
+
+zonkExpr env (HsHetMetCSP c e)
+ = do c' <- zonkTcTypeToType env c
+ e' <- zonkLExpr env e
+ return (HsHetMetCSP c' e')
+
zonkExpr env (SectionL expr op)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkLExpr env op `thenM` \ new_op ->
; e' <- zonkLExpr env e
; return $ HsVect v' (Just e')
}
+ zonkVect env (HsNoVect v)
+ = do { v' <- wrapLocM (zonkIdBndr env) v
+ ; return $ HsNoVect v'
+ }
\end{code}
%************************************************************************
import TcUnify
import TcIface
import TcType
+import TysPrim ( ecKind )
import {- Kind parts of -} Type
import Var
import VarSet
= do { ty' <- kc_check_lhs_type ty exp_kind; return (HsParTy ty') }
kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind
- = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 ty2
+ = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
; (fun_ty', fun_kind) <- kc_lhs_type fun_ty
; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind
; return (mkHsAppTys fun_ty' arg_tys') }
ty' <- kcLiftedType ty
return (HsPArrTy ty', liftedTypeKind)
+kc_hs_type (HsModalBoxType ecn ty) = do
+ kc_check_hs_type (HsTyVar ecn) (EK ecKind EkUnk)
+ ty' <- kcLiftedType ty
+ return (HsModalBoxType ecn ty', liftedTypeKind)
+
kc_hs_type (HsKindSig ty k) = do
ty' <- kc_check_lhs_type ty (EK k EkKindSig)
return (HsKindSig ty' k, k)
return (HsOpTy ty1' op ty2', res_kind)
kc_hs_type (HsAppTy ty1 ty2) = do
+ let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
(fun_ty', fun_kind) <- kc_lhs_type fun_ty
(arg_tys', res_kind) <- kcApps fun_ty fun_kind arg_tys
return (mkHsAppTys fun_ty' arg_tys', res_kind)
- where
- (fun_ty, arg_tys) = splitHsAppTys ty1 ty2
kc_hs_type (HsPredTy pred)
= wrongPredErr pred
-- This improves error message; Trac #2994
; kc_check_lhs_types args_w_kinds }
- splitHsAppTys :: LHsType Name -> LHsType Name -> (LHsType Name, [LHsType Name])
- splitHsAppTys fun_ty arg_ty = split fun_ty [arg_ty]
- where
- split (L _ (HsAppTy f a)) as = split f (a:as)
- split f as = (f,as)
-
- mkHsAppTys :: LHsType Name -> [LHsType Name] -> HsType Name
- mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
- mkHsAppTys fun_ty (arg_ty:arg_tys)
- = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
- where
- mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of
- -- the application; they are
- -- never used
---------------------------
splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind)
checkWiredInTyCon parrTyCon
return (mkPArrTy tau_ty)
+ds_type (HsModalBoxType ecn ty) = do
+ tau_ty <- dsHsType ty
+ checkWiredInTyCon hetMetCodeTypeTyCon
+ return (mkHetMetCodeTypeTy (mkTyVar ecn ecKind) tau_ty)
+
ds_type (HsTupleTy boxity tys) = do
tau_tys <- dsHsTypes tys
checkWiredInTyCon tycon
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
tcl_meta = meta_var,
- tcl_untch = initTyVarUnique
+ tcl_untch = initTyVarUnique,
+ tcl_hetMetLevel = []
} ;
} ;
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
- setSrcSpan loc thing_inside
- | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
- | otherwise = thing_inside -- Don't overwrite useful info with useless
+ setSrcSpan loc@(RealSrcSpan _) thing_inside
+ = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
+ -- Don't overwrite useful info with useless:
+ setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
-- (captureConstraints m) runs m, and returns the type constraints it generates
captureConstraints thing_inside
= do { lie_var <- newTcRef emptyWC ;
- res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
- thing_inside ;
- lie <- readTcRef lie_var ;
- return (res, lie) }
+ res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
+ thing_inside ;
+ lie <- readTcRef lie_var ;
+ return (res, lie) }
captureUntouchables :: TcM a -> TcM (a, Untouchables)
captureUntouchables thing_inside
= updLclEnv upd thing_inside
where
upd env = env { tcl_env = tcl_env lcl_env,
- tcl_tyvars = tcl_tyvars lcl_env }
+ tcl_tyvars = tcl_tyvars lcl_env }
+
+ traceTcConstraints :: String -> TcM ()
+ traceTcConstraints msg
+ = do { lie_var <- getConstraintVar
+ ; lie <- readTcRef lie_var
+ ; traceTc (msg ++ "LIE:") (ppr lie)
+ }
\end{code}
%************************************************************************
- %* *
- Template Haskell context
- %* *
+ %* *
+ Template Haskell context
+ %* *
%************************************************************************
\begin{code}
# package-data.mk is sufficient, as that in turn depends on all the
# libraries
utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk
- utils/ghc-pwd/dist/package-data.mk: compiler/stage2/package-data.mk
+ utils/ghc-pwd/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/ghc-cabal/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/ghc-pkg/dist-install/package-data.mk: compiler/stage2/package-data.mk
utils/hsc2hs/dist-install/package-data.mk: compiler/stage2/package-data.mk
- utils/compare_sizes/dist/package-data.mk: compiler/stage2/package-data.mk
- utils/runghc/dist/package-data.mk: compiler/stage2/package-data.mk
+ utils/compare_sizes/dist-install/package-data.mk: compiler/stage2/package-data.mk
+ utils/runghc/dist-install/package-data.mk: compiler/stage2/package-data.mk
# add the final two package.conf dependencies: ghc-prim depends on RTS,
# and RTS depends on libffi.
mk/config.mk.in \
$(INPLACE_BIN)/mkdirhier \
utils/ghc-cabal/dist-install/build/tmp/ghc-cabal \
- utils/ghc-pwd/dist/build/tmp/ghc-pwd \
+ utils/ghc-pwd/dist-install/build/tmp/ghc-pwd \
$(BINDIST_WRAPPERS) \
$(BINDIST_PERL_SOURCES) \
$(BINDIST_LIBS) \
.PHONY: phase_1_builds
phase_1_builds: $(PACKAGE_DATA_MKS)
+# -----------------------------------------------------------------------------
+# Support for writing GHC passes in Coq
+
+compiler/hetmet/Makefile:
+ git submodule update --init compiler/hetmet
+ cd compiler/hetmet/; git checkout master
+compiler/hetmet/build/CoqPass.hs: compiler/hetmet/Makefile $(wildcard compiler/hetmet/src/*.v) $(wildcard compiler/hetmet/src/*.hs)
+ cd compiler/hetmet; make build/CoqPass.hs
+compiler/stage1/build/CoqPass.hs: compiler/hetmet/build/CoqPass.hs
+ cp compiler/hetmet/build/CoqPass.hs $@
+compiler/stage2/build/CoqPass.hs: compiler/hetmet/build/CoqPass.hs
+ cp compiler/hetmet/build/CoqPass.hs $@
projects / ghc-hetmet.git / commitdiff