diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.hs similarity index 97% rename from compiler/deSugar/Check.lhs rename to compiler/deSugar/Check.hs index b5b9544cb402bae0ac54c03bf589b68d40fead61..7284db3bc8e4b6407ebb51869a5785fea5c47a72 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 -% -% Author: Juan J. Quintela +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +Author: Juan J. Quintela +-} -\begin{code} {-# LANGUAGE CPP #-} module Check ( check , ExhaustivePat ) where @@ -29,8 +29,8 @@ import Util import BasicTypes import Outputable import FastString -\end{code} +{- This module performs checks about if one list of equations are: \begin{itemize} \item Overlapped @@ -95,8 +95,8 @@ Then we need to use InPats. Juan Quintela 5 JUL 1998\\ User-friendliness and compiler writers are no friends. \end{quotation} +-} -\begin{code} type WarningPat = InPat Name type ExhaustivePat = ([WarningPat], [(Name, [HsLit])]) type EqnNo = Int @@ -122,11 +122,8 @@ untidy_exhaustive (pats, messages) = untidy_message :: (Name, [HsLit]) -> (Name, [HsLit]) untidy_message (string, lits) = (string, map untidy_lit lits) -\end{code} - -The function @untidy@ does the reverse work of the @tidy_pat@ function. -\begin{code} +-- The function @untidy@ does the reverse work of the @tidy_pat@ function. type NeedPars = Bool @@ -144,9 +141,9 @@ untidy b (L loc p) = L loc (untidy' b p) untidy' _ (LitPat lit) = LitPat (untidy_lit lit) untidy' _ p@(ConPatIn _ (PrefixCon [])) = p untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) - untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing + untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys - untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat" + untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat" untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" untidy' _ (LazyPat {}) = panic "Check.untidy: LazyPat" @@ -177,8 +174,8 @@ pars _ p = unLoc p untidy_lit :: HsLit -> HsLit untidy_lit (HsCharPrim src c) = HsChar src c untidy_lit lit = lit -\end{code} +{- This equation is the same that check, the only difference is that the boring work is done, that work needs to be done only once, this is the reason top have two functions, check is the external interface, @@ -203,9 +200,7 @@ There are several cases: vars in the first column, we actuate in consequence. \end{itemize} - - -\begin{code} +-} check' :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], -- Pattern scheme that might not be matched at all @@ -213,7 +208,7 @@ check' :: [(EqnNo, EquationInfo)] check' [] = ([],emptyUniqSet) -- Was ([([],[])], emptyUniqSet) - -- But that (a) seems weird, and (b) triggered Trac #7669 + -- But that (a) seems weird, and (b) triggered Trac #7669 -- So now I'm just doing the simple obvious thing check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs) @@ -242,36 +237,34 @@ check' qs some_constructors = any is_con first_pats some_literals = any is_lit first_pats only_vars = all is_var first_pats -\end{code} +{- Here begins the code to deal with literals, we need to split the matrix in different matrix beginning by each literal and a last matrix with the rest of values. +-} -\begin{code} split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) split_by_literals qs = process_literals used_lits qs where used_lits = get_used_lits qs -\end{code} +{- @process_explicit_literals@ is a function that process each literal that appears in the column of the matrix. +-} -\begin{code} process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs) where pats_indexs = map (\x -> construct_literal_matrix x qs) lits (pats,indexs) = unzip pats_indexs -\end{code} - +{- @process_literals@ calls @process_explicit_literals@ to deal with the literals that appears in the matrix and deal also with the rest of the cases. It must be one Variable to be complete. - -\begin{code} +-} process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) process_literals used_lits qs @@ -285,12 +278,12 @@ process_literals used_lits qs pats_default = [(nlWildPatName:ps,constraints) | (ps,constraints) <- (pats')] ++ pats indexs_default = unionUniqSets indexs' indexs -\end{code} +{- Here we have selected the literal and we will select all the equations that begins for that literal and create a new matrix. +-} -\begin{code} construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) construct_literal_matrix lit qs = (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs) @@ -307,12 +300,12 @@ remove_first_column_lit lit qs where shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps } shift_pat _ = panic "Check.shift_var: no patterns" -\end{code} +{- This function splits the equations @qs@ in groups that deal with the same constructor. +-} -\begin{code} split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) split_by_constructor qs | null used_cons = ([], mkUniqSet $ map fst qs) @@ -321,19 +314,19 @@ split_by_constructor qs where used_cons = get_used_cons qs unused_cons = get_unused_cons used_cons -\end{code} +{- The first column of the patterns matrix only have vars, then there is nothing to do. +-} -\begin{code} first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPatName:xs,ys)) pats,indexs) where (pats, indexs) = check' (map remove_var qs) -\end{code} +{- This equation takes a matrix of patterns and split the equations by constructor, using all the constructors that appears in the first column of the pattern matching. @@ -341,8 +334,8 @@ of the pattern matching. We can need a default clause or not ...., it depends if we used all the constructors or not explicitly. The reasoning is similar to @process_literals@, the difference is that here the default case is not always needed. +-} -\begin{code} no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs) where @@ -369,8 +362,8 @@ construct_matrix con qs = (map (make_con con) pats,indexs) where (pats,indexs) = (check' (remove_first_column con qs)) -\end{code} +{- Here remove first column is more difficult that with literals due to the fact that constructors can have arguments. @@ -384,8 +377,8 @@ is transformed in: x xs y _ _ y \end{verbatim} +-} -\begin{code} remove_first_column :: Pat Id -- Constructor -> [(EqnNo, EquationInfo)] -> [(EqnNo, EquationInfo)] @@ -536,8 +529,8 @@ is_var_lit _ (WildPat _) = True is_var_lit lit pat | Just lit' <- get_lit pat = lit == lit' | otherwise = False -\end{code} +{- The difference beteewn @make_con@ and @make_whole_con@ is that @make_wole_con@ creates a new constructor with all their arguments, and @make_con@ takes a list of argumntes, creates the contructor getting their @@ -570,12 +563,12 @@ In particular: \\ @((:) x xs)@ & returns to be & @(x:xs)@ \\ @(x:(...:[])@ & returns to be & @[x,...]@ \end{tabular} -% + The difficult case is the third one becouse we need to follow all the contructors until the @[]@ to know that we need to use the second case, not the second. \fbox{\ ???\ } -% -\begin{code} +-} + isInfixCon :: DataCon -> Bool isInfixCon con = isDataSymOcc (getOccName con) @@ -629,8 +622,8 @@ make_whole_con con | isInfixCon con = nlInfixConPat name where name = getName con pats = [nlWildPatName | _ <- dataConOrigArgTys con] -\end{code} +{- ------------------------------------------------------------------------ Tidying equations ------------------------------------------------------------------------ @@ -640,8 +633,8 @@ that is, it removes syntactic sugar, reducing the number of cases that must be handled by the main checking algorithm. One difference is that here we can do *all* the tidying at once (recursively), rather than doing it incrementally. +-} -\begin{code} tidy_eqn :: EquationInfo -> EquationInfo tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn), eqn_rhs = tidy_rhs (eqn_rhs eqn) } @@ -778,4 +771,3 @@ tidy_con con (RecCon (HsRecFields fs _)) insertNm nm p (x@(n,_):xs) | nm == n = (nm,p):xs | otherwise = x : insertNm nm p xs -\end{code} diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.hs similarity index 97% rename from compiler/deSugar/Coverage.lhs rename to compiler/deSugar/Coverage.hs index 1c64b1ab8a4188dd3113836918297e869dee7b1c..8ae893314f2ac0128a8a33a24c2770a2f8b104f3 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.hs @@ -1,8 +1,8 @@ -% -% (c) Galois, 2006 -% (c) University of Glasgow, 2007 -% -\begin{code} +{- +(c) Galois, 2006 +(c) University of Glasgow, 2007 +-} + {-# LANGUAGE NondecreasingIndentation #-} module Coverage (addTicksToBinds, hpcInitCode) where @@ -43,16 +43,15 @@ import Trace.Hpc.Util import BreakArray import Data.Map (Map) import qualified Data.Map as Map -\end{code} +{- +************************************************************************ +* * +* The main function: addTicksToBinds +* * +************************************************************************ +-} -%************************************************************************ -%* * -%* The main function: addTicksToBinds -%* * -%************************************************************************ - -\begin{code} addTicksToBinds :: DynFlags -> Module @@ -526,7 +525,7 @@ addTickHsExpr (ExplicitList ty wit es) = liftM3 ExplicitList (return ty) (addTickWit wit) - (mapM (addTickLHsExpr) es) + (mapM (addTickLHsExpr) es) where addTickWit Nothing = return Nothing addTickWit (Just fln) = do fln' <- addTickHsExpr fln return (Just fln') @@ -808,7 +807,7 @@ addTickHsCmd (HsCmdArrForm e fix cmdtop) = (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) -addTickHsCmd (HsCmdCast co cmd) +addTickHsCmd (HsCmdCast co cmd) = liftM2 HsCmdCast (return co) (addTickHsCmd cmd) -- Others should never happen in a command context. @@ -918,9 +917,7 @@ liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a) liftL f (L loc a) = do a' <- f a return $ L loc a' -\end{code} -\begin{code} data TickTransState = TT { tickBoxCount:: Int , mixEntries :: [MixEntry_] } @@ -1164,18 +1161,12 @@ mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" hpcSrcSpan :: SrcSpan hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") -\end{code} - -\begin{code} matchesOneOfMany :: [LMatch Id body] -> Bool matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 where matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss -\end{code} - -\begin{code} type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) -- For the hash value, we hash everything: the file name, @@ -1187,13 +1178,13 @@ type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int mixHash file tm tabstop entries = fromIntegral $ hashString (show $ Mix file tm 0 tabstop entries) -\end{code} -%************************************************************************ -%* * -%* initialisation -%* * -%************************************************************************ +{- +************************************************************************ +* * +* initialisation +* * +************************************************************************ Each module compiled with -fhpc declares an initialisation function of the form `hpc_init_()`, which is emitted into the _stub.c file @@ -1207,8 +1198,8 @@ static void hpc_init_Main(void) __attribute__((constructor)); static void hpc_init_Main(void) {extern StgWord64 _hpc_tickboxes_Main_hpc[]; hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} +-} -\begin{code} hpcInitCode :: Module -> HpcInfo -> SDoc hpcInitCode _ (NoHpcInfo {}) = Outputable.empty hpcInitCode this_mod (HpcInfo tickCount hashNo) @@ -1240,4 +1231,3 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo) = module_name | otherwise = package_name <> char '/' <> module_name -\end{code} diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.hs similarity index 91% rename from compiler/deSugar/Desugar.lhs rename to compiler/deSugar/Desugar.hs index 500c411ffa113d2a74061f4e9ea2dde85749f8fd..ac4bdb2b3385ee85361574f696218c9ac27bf312 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + The Desugarer: turning HsSyn into Core. +-} -\begin{code} {-# LANGUAGE CPP #-} module Desugar ( deSugar, deSugarExpr ) where @@ -52,15 +52,15 @@ import OrdList import Data.List import Data.IORef import Control.Monad( when ) -\end{code} -%************************************************************************ -%* * -%* The main function: deSugar -%* * -%************************************************************************ +{- +************************************************************************ +* * +* The main function: deSugar +* * +************************************************************************ +-} -\begin{code} -- | Main entry point to the desugarer. deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) -- Can modify PCS by faulting in more declarations @@ -212,8 +212,8 @@ combineEvBinds (NonRec b r : bs) val_prs | otherwise = NonRec b r : combineEvBinds bs val_prs combineEvBinds (Rec prs : bs) val_prs = combineEvBinds bs (prs ++ val_prs) -\end{code} +{- Note [Top-level evidence] ~~~~~~~~~~~~~~~~~~~~~~~~~ Top-level evidence bindings may be mutually recursive with the top-level value @@ -223,9 +223,8 @@ when computing dependencies. So we pull out the type/coercion variables (which are in dependency order), and Rec the rest. +-} - -\begin{code} deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr) deSugarExpr hsc_env tc_expr @@ -249,15 +248,15 @@ deSugarExpr hsc_env tc_expr Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr) ; return (msgs, mb_core_expr) } -\end{code} -%************************************************************************ -%* * -%* Add rules and export flags to binders -%* * -%************************************************************************ +{- +************************************************************************ +* * +* Add rules and export flags to binders +* * +************************************************************************ +-} -\begin{code} addExportFlagsAndRules :: HscTarget -> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)] @@ -299,9 +298,8 @@ addExportFlagsAndRules target exports keep_alive rules prs is_exported :: Name -> Bool is_exported | targetRetainsAllBindings target = isExternalName | otherwise = (`elemNameSet` exports) -\end{code} - +{- Note [Adding export flags] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Set the no-discard flag if either @@ -338,13 +336,12 @@ Reason thereby get dropped -%************************************************************************ -%* * -%* Desugaring transformation rules -%* * -%************************************************************************ - -\begin{code} +************************************************************************ +* * +* Desugaring transformation rules +* * +************************************************************************ +-} dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule) dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) @@ -378,7 +375,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) inline_shadows_rule -- Function can be inlined before rule fires | wopt Opt_WarnInlineRuleShadowing dflags - , isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id) + , isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id) -- If imported with no unfolding, no worries = case (idInlineActivation fn_id, act) of (NeverActive, _) -> False @@ -422,8 +419,7 @@ unfold_coerce bndrs lhs rhs = do (bndrs,wrap) <- go vs return (v:bndrs, wrap) -\end{code} - +{- Note [Desugaring RULE left hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the LHS of a RULE we do *not* want to desugar @@ -455,13 +451,13 @@ corresponding `co :: a ~#R b` and wrap the LHS and the RHS in `let c = MkCoercible co in ...`. This is later simplified to the desired form by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS). -%************************************************************************ -%* * -%* Desugaring vectorisation declarations -%* * -%************************************************************************ +************************************************************************ +* * +* Desugaring vectorisation declarations +* * +************************************************************************ +-} -\begin{code} dsVect :: LVectDecl Id -> DsM CoreVect dsVect (L loc (HsVect (L _ v) rhs)) = putSrcSpanDs loc $ @@ -486,4 +482,3 @@ dsVect (L _loc (HsVectInstOut inst)) = return $ VectInst (instanceDFunId inst) dsVect vi@(L _ (HsVectInstIn _)) = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi) -\end{code} diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.hs similarity index 98% rename from compiler/deSugar/DsArrows.lhs rename to compiler/deSugar/DsArrows.hs index 8f8e2d9f163f0dffa1e3d34200adc090911f98b7..1a7321057159d6706205a2fd9cb47fe62e6594c7 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Desugaring arrow commands +-} -\begin{code} {-# LANGUAGE CPP #-} module DsArrows ( dsProcExpr ) where @@ -48,9 +48,7 @@ import SrcLoc import ListSetOps( assocDefault ) import FastString import Data.List -\end{code} -\begin{code} data DsCmdEnv = DsCmdEnv { arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr } @@ -137,12 +135,12 @@ mkSndExpr a_ty b_ty = do pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty) return (Lam pair_var (coreCasePair pair_var a_var b_var (Var b_var))) -\end{code} +{- Build case analysis of a tuple. This cannot be done in the DsM monad, because the list of variables is typically not yet defined. +-} -\begin{code} -- coreCaseTuple [u1..] v [x1..xn] body -- = case v of v { (x1, .., xn) -> body } -- But the matching may be nested if the tuple is very big @@ -155,9 +153,7 @@ coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body = Case (Var scrut_var) scrut_var (exprType body) [(DataAlt (tupleCon BoxedTuple 2), [var1, var2], body)] -\end{code} -\begin{code} mkCorePairTy :: Type -> Type -> Type mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] @@ -166,8 +162,8 @@ mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] mkCoreUnitExpr :: CoreExpr mkCoreUnitExpr = mkCoreTup [] -\end{code} +{- The input is divided into a local environment, which is a flat tuple (unless it's too big), and a stack, which is a right-nested pair. In general, the input has the form @@ -176,8 +172,8 @@ In general, the input has the form where xi are the environment values, and si the ones on the stack, with s1 being the "top", the first one to be matched with a lambda. +-} -\begin{code} envStackType :: [Id] -> Type -> Type envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty @@ -250,17 +246,12 @@ matchVarStack (param_id:param_ids) stack_id body = do (tail_id, tail_code) <- matchVarStack param_ids stack_id body pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id)) return (pair_id, coreCasePair pair_id param_id tail_id tail_code) -\end{code} -\begin{code} mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id mkHsEnvStackExpr env_ids stack_id = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] -\end{code} - -Translation of arrow abstraction -\begin{code} +-- Translation of arrow abstraction -- D; xs |-a c : () --> t' ---> c' -- -------------------------- @@ -287,8 +278,8 @@ dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do (Lam var match_code) core_cmd return (mkLets meth_binds proc_code) -\end{code} +{- Translation of a command judgement of the form D; xs |-a c : stk --> t @@ -296,8 +287,8 @@ Translation of a command judgement of the form to an expression e such that D |- e :: a (xs, stk) t +-} -\begin{code} dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id] -> DsM (CoreExpr, IdSet) dsLCmd ids local_vars stk_ty res_ty cmd env_ids @@ -483,8 +474,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) core_if (do_choice ids then_ty else_ty res_ty core_then core_else), fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else) -\end{code} +{- Case commands are treated in much the same way as if commands (see above) except that there are more alternatives. For example @@ -509,8 +500,8 @@ case bodies, containing the following fields: input type of the arrow * a CoreExpr for an arrow built by combining the translated command bodies with |||. +-} -\begin{code} dsCmd ids local_vars stack_ty res_ty (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin })) env_ids = do @@ -678,13 +669,11 @@ trimInput build_arrow (core_cmd, free_vars) <- build_arrow env_ids return (core_cmd, free_vars, varSetElems free_vars)) -\end{code} - +{- Translation of command judgements of the form D |-a do { ss } : t - -\begin{code} +-} dsCmdDo :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement @@ -731,11 +720,12 @@ dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do core_stmts, fv_stmt) -\end{code} +{- A statement maps one local environment to another, and is represented as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. -\begin{code} +-} + dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id] -> DsM (CoreExpr, IdSet) dsCmdLStmt ids local_vars out_ids cmd env_ids @@ -994,10 +984,10 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do return (core_loop, env1_id_set, env1_ids) -\end{code} +{- A sequence of statements (as in a rec) is desugared to an arrow between two environments (no stack) -\begin{code} +-} dsfixCmdStmts :: DsCmdEnv -- arrow combinators @@ -1038,11 +1028,9 @@ dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do fv_stmt) dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" -\end{code} -Match a list of expressions against a list of patterns, left-to-right. +-- Match a list of expressions against a list of patterns, left-to-right. -\begin{code} matchSimplys :: [CoreExpr] -- Scrutinees -> HsMatchContext Name -- Match kind -> [LPat Id] -- Patterns they should match @@ -1054,11 +1042,9 @@ matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do match_code <- matchSimplys exps ctxt pats result_expr fail_expr matchSimply exp ctxt pat match_code fail_expr matchSimplys _ _ _ _ _ = panic "matchSimplys" -\end{code} -List of leaf expressions, with set of variables bound in each +-- List of leaf expressions, with set of variables bound in each -\begin{code} leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) = let @@ -1070,11 +1056,9 @@ leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) mkVarSet (collectLStmtsBinders stmts) `unionVarSet` defined_vars) | L _ (GRHS stmts body) <- grhss] -\end{code} -Replace the leaf commands in a match +-- Replace the leaf commands in a match -\begin{code} replaceLeavesMatch :: Type -- new result type -> [Located (body' Id)] -- replacement leaf expressions of that type @@ -1095,11 +1079,9 @@ replaceLeavesGRHS replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) = (leaves, L loc (GRHS stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" -\end{code} -Balanced fold of a non-empty list. +-- Balanced fold of a non-empty list. -\begin{code} foldb :: (a -> a -> a) -> [a] -> a foldb _ [] = error "foldb of empty list" foldb _ [x] = x @@ -1108,8 +1090,8 @@ foldb f xs = foldb f (fold_pairs xs) fold_pairs [] = [] fold_pairs [x] = [x] fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs -\end{code} +{- Note [Dictionary binders in ConPatOut] See also same Note in HsUtils ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The following functions to collect value variables from patterns are @@ -1129,8 +1111,8 @@ Here p77 is a local binding for the (+) operation. See comments in HsUtils for why the other version does not include these bindings. +-} -\begin{code} collectPatBinders :: LPat Id -> [Id] collectPatBinders pat = collectl pat [] @@ -1193,5 +1175,3 @@ collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss] collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids - -\end{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.hs similarity index 96% rename from compiler/deSugar/DsBinds.lhs rename to compiler/deSugar/DsBinds.hs index bc1b3528cae98359693fd517086a02fee41c8570..b2ca4dca2ce68a580baf408ee1dfaffc24e12f61 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.hs @@ -1,15 +1,15 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Pattern-matching bindings (HsBinds and MonoBinds) Handles @HsBinds@; those at the top level require different handling, in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower levels it is preserved with @let@/@letrec@s). +-} -\begin{code} {-# LANGUAGE CPP #-} module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, @@ -70,15 +70,15 @@ import Util import Control.Monad( when ) import MonadUtils import Control.Monad(liftM) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[dsMonoBinds]{Desugaring a @MonoBinds@} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) dsTopLHsBinds binds = ds_lhs_binds binds @@ -244,7 +244,7 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs -- See Note [ClassOp/DFun selection] in TcInstDcls -- See Note [Single-method classes] in TcInstDcls mk_dfun_w_stuff is_newtype - | is_newtype + | is_newtype = gbl_id `setIdUnfolding` mkInlineUnfolding (Just 0) rhs `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } | otherwise @@ -261,8 +261,8 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs dictArity :: [Var] -> Arity -- Don't count coercion variables in arity dictArity dicts = count isId dicts -\end{code} +{- [Desugaring AbsBinds] ~~~~~~~~~~~~~~~~~~~~~ In the general AbsBinds case we desugar the binding to this: @@ -425,8 +425,8 @@ Note that * The RHS of f_spec, has a *copy* of 'binds', so that it can fully specialise it. +-} -\begin{code} ------------------------ dsSpecs :: CoreExpr -- Its rhs -> TcSpecPrags @@ -538,9 +538,8 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) specOnInline :: Name -> MsgDoc specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") <+> quotes (ppr f) -\end{code} - +{- Note [Activation pragmas for SPECIALISE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ From a user SPECIALISE pragma for f, we generate @@ -582,13 +581,13 @@ NOINLINE [k] f SPEC f :: ty [n] INLINE [k] -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Adding inline pragmas} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr]) -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs @@ -673,8 +672,8 @@ decomposeRuleLhs orig_bndrs orig_lhs where rhs_fvs = exprFreeVars r needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d -\end{code} +{- Note [Decomposing the left-hand side of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are several things going on here. @@ -731,7 +730,7 @@ The drop_dicts algorithm is based on these observations: * The "needed variables" are simply the orig_bndrs. Consider f :: (Eq a, Show b) => a -> b -> String - {-# SPECIALISE f :: (Show b) => Int -> b -> String + ... SPECIALISE f :: (Show b) => Int -> b -> String ... Then orig_bndrs includes the *quantified* dictionaries of the type namely (dsb::Show b), but not the one for Eq Int @@ -770,7 +769,7 @@ Note [Unused spec binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f :: a -> a - {-# SPECIALISE f :: Eq a => a -> a #-} + ... SPECIALISE f :: Eq a => a -> a ... It's true that this *is* a more specialised type, but the rule we get is something like this: f_spec d = f @@ -790,7 +789,7 @@ over it too. *Any* dict with that type will do. So for example when you have f :: Eq a => a -> a f = - {-# SPECIALISE f :: Int -> Int #-} + ... SPECIALISE f :: Int -> Int ... Then we get the SpecPrag SpecPrag (f Int dInt) @@ -807,14 +806,14 @@ utterly bogus. So we really make a fresh Id, with the same unique and type as the old one, but with an Internal name and no IdInfo. -%************************************************************************ -%* * +************************************************************************ +* * Desugaring evidence -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr dsHsWrapper WpHole e = return e dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty) @@ -990,8 +989,8 @@ ds_tc_coercion subst tc_co ds_ev_id subst v | Just co <- Coercion.lookupCoVar subst v = co | otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co) -\end{code} +{- Note [Simple coercions] ~~~~~~~~~~~~~~~~~~~~~~~ We have a special case for coercions that are simple variables. @@ -1016,5 +1015,4 @@ which simpleOpt (currently) doesn't remove. So the rule never matches. Maybe simpleOpt should be smarter. But it seems like a good plan to simply never generate the redundant box/unbox in the first place. - - +-} diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.hs similarity index 98% rename from compiler/deSugar/DsCCall.lhs rename to compiler/deSugar/DsCCall.hs index deb3106391645cbac2cf8036dd937b026bc793c9..5c5fde0b148f0c2175e2ca7b9fb682c88977852e 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1994-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + Desugaring foreign calls +-} -\begin{code} {-# LANGUAGE CPP #-} module DsCCall ( dsCCall @@ -45,8 +45,8 @@ import Outputable import Util import Data.Maybe -\end{code} +{- Desugaring of @ccall@s consists of adding some state manipulation, unboxing any boxed primitive arguments and boxing the result if desired. @@ -81,8 +81,8 @@ follows: \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of (StateAnd# result# state#) -> (R# result#, realWorld#) \end{verbatim} +-} -\begin{code} dsCCall :: CLabelString -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) -> Safety -- Safety of the call @@ -121,9 +121,7 @@ mkFCall dflags uniq the_fcall val_args res_ty tyvars = varSetElems (tyVarsOfType body_ty) ty = mkForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty -\end{code} -\begin{code} unboxArg :: CoreExpr -- The supplied argument -> DsM (CoreExpr, -- To pass as the actual argument CoreExpr -> CoreExpr -- Wrapper to unbox the arg @@ -195,10 +193,7 @@ unboxArg arg (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3 Just arg3_tycon = maybe_arg3_tycon -\end{code} - -\begin{code} boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr) @@ -385,4 +380,3 @@ maybeNarrow dflags tycon | tycon `hasKey` word32TyConKey && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e | otherwise = id -\end{code} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.hs similarity index 92% rename from compiler/deSugar/DsExpr.lhs rename to compiler/deSugar/DsExpr.hs index c9134c9944cf69317476692d6fc40093a1cd3923..e94936d48c0b1e04b71069463b180f2b98ba77a6 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Desugaring exporessions. +-} -\begin{code} {-# LANGUAGE CPP #-} module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where @@ -61,16 +61,15 @@ import Outputable import FastString import Control.Monad -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * dsLocalBinds, dsValBinds -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr dsLocalBinds EmptyLocalBinds body = return body dsLocalBinds (HsValBinds binds) body = dsValBinds binds body @@ -86,7 +85,7 @@ dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr dsIPBinds (IPBinds ip_binds ev_binds) body = do { ds_binds <- dsTcEvBinds ev_binds ; let inner = mkCoreLets ds_binds body - -- The dict bindings may not be in + -- The dict bindings may not be in -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where @@ -116,7 +115,7 @@ ds_val_bind (_is_rec, binds) body case prs of [] -> return body _ -> return (Let (Rec prs) body) } - -- Use a Rec regardless of is_rec. + -- Use a Rec regardless of is_rec. -- Why? Because it allows the binds to be all -- mixed up, which is what happens in one rare case -- Namely, for an AbsBind with no tyvars and no dicts, @@ -136,11 +135,11 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] = do { let body1 = foldr bind_export body exports bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body) - body1 lbinds + body1 lbinds ; ds_binds <- dsTcEvBinds ev_binds ; return (mkCoreLets ds_binds body2) } -dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn +dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn , fun_tick = tick, fun_infix = inf }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed @@ -155,7 +154,7 @@ dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body -- ==> case rhs of C x# y# -> body do { rhs <- dsGuarded grhss ty ; let upat = unLoc pat - eqn = EqnInfo { eqn_pats = [upat], + eqn = EqnInfo { eqn_pats = [upat], eqn_rhs = cantFailMatchResult body } ; var <- selectMatchVar upat ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) @@ -175,15 +174,14 @@ strictMatchOnly (FunBind { fun_id = L _ id }) = isUnLiftedType (idType id) strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} dsLExpr :: LHsExpr Id -> DsM CoreExpr dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e @@ -203,7 +201,7 @@ dsExpr (HsWrap co_fn e) ; warnAboutIdentities dflags e' (exprType wrapped_e) ; return wrapped_e } -dsExpr (NegApp expr neg_expr) +dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr dsExpr (HsLam a_Match) @@ -218,8 +216,8 @@ dsExpr (HsApp fun arg) = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar" -\end{code} +{- Note [Desugaring vars] ~~~~~~~~~~~~~~~~~~~~~~ In one situation we can get a *coercion* variable in a HsVar, namely @@ -235,7 +233,7 @@ Then we get That 'g' in the 'in' part is an evidence variable, and when converting to core it must become a CO. - + Operator sections. At first it looks as if we can convert \begin{verbatim} (expr op) @@ -256,12 +254,12 @@ for example. So we convert instead to \end{verbatim} If \tr{expr} is actually just a variable, say, then the simplifier will sort it out. +-} -\begin{code} dsExpr (OpApp e1 op _ e2) = -- for the type of y, we need the type of op's 2nd argument mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2] - + dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e) = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr @@ -321,9 +319,9 @@ dsExpr (HsLet binds body) = do -- dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) -dsExpr (HsDo DoExpr stmts _) = dsDo stmts -dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts -dsExpr (HsDo MDoExpr stmts _) = dsDo stmts +dsExpr (HsDo DoExpr stmts _) = dsDo stmts +dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts +dsExpr (HsDo MDoExpr stmts _) = dsDo stmts dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts dsExpr (HsIf mb_fun guard_expr then_expr else_expr) @@ -347,14 +345,14 @@ dsExpr (HsMultiIf res_ty alts) where mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty (ptext (sLit "multi-way if")) -\end{code} - +{- \noindent \underline{\bf Various data construction things} -% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -\begin{code} -dsExpr (ExplicitList elt_ty wit xs) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} + +dsExpr (ExplicitList elt_ty wit xs) = dsExplicitList elt_ty wit xs -- We desugar [:x1, ..., xn:] as @@ -375,7 +373,7 @@ dsExpr (ExplicitPArr ty xs) = do dsExpr (ArithSeq expr witness seq) = case witness of Nothing -> dsArithSeq expr seq - Just fl -> do { + Just fl -> do { ; fl' <- dsExpr fl ; newArithSeq <- dsArithSeq expr seq ; return (App fl' newArithSeq)} @@ -390,18 +388,18 @@ dsExpr (PArrSeq _ _) = panic "DsExpr.dsExpr: Infinite parallel array!" -- the parser shouldn't have generated it and the renamer and typechecker -- shouldn't have let it through -\end{code} +{- \noindent \underline{\bf Record construction and update} -% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For record construction we do this (assuming T has three arguments) \begin{verbatim} T { op2 = e } ==> - let err = /\a -> recConErr a - T (recConErr t1 "M.lhs/230/op1") - e + let err = /\a -> recConErr a + T (recConErr t1 "M.lhs/230/op1") + e (recConErr t1 "M.lhs/230/op3") \end{verbatim} @recConErr@ then converts its arugment string into a proper message @@ -412,13 +410,13 @@ before printing it as We also handle @C{}@ as valid construction syntax for an unlabelled constructor @C@, setting all of @C@'s fields to bottom. +-} -\begin{code} dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do con_expr' <- dsExpr con_expr let (arg_tys, _) = tcSplitFunTys (exprType con_expr') - -- A newtype in the corner should be opaque; + -- A newtype in the corner should be opaque; -- hence TcType.tcSplitFunTys mk_arg (arg_ty, lbl) -- Selector id has the field label as its name @@ -430,14 +428,14 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do labels = dataConFieldLabels (idDataCon data_con_id) -- The data_con_id is guaranteed to be the wrapper id of the constructor - + con_args <- if null labels then mapM unlabelled_bottom arg_tys else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) - + return (mkCoreApps con_expr' con_args) -\end{code} +{- Record update is a little harder. Suppose we have the decl: \begin{verbatim} data T = T1 {op1, op2, op3 :: Int} @@ -461,17 +459,17 @@ dictionaries. Note [Update for GADTs] ~~~~~~~~~~~~~~~~~~~~~~~ -Consider +Consider data T a b where T1 { f1 :: a } :: T a Int -Then the wrapper function for T1 has type +Then the wrapper function for T1 has type $WT1 :: a -> T a Int But if x::T a b, then x { f1 = v } :: T a b (not T a Int!) So we need to cast (T a Int) to (T a b). Sigh. +-} -\begin{code} dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) cons_to_upd in_inst_tys out_inst_tys) | null fields @@ -511,14 +509,14 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) add_field_binds [] expr = expr add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) - -- Awkwardly, for families, the match goes + -- Awkwardly, for families, the match goes -- from instance type to family type tycon = dataConTyCon (head cons_to_upd) in_ty = mkTyConApp tycon in_inst_tys out_ty = mkFamilyTyConApp tycon out_inst_tys mk_alt upd_fld_env con - = do { let (univ_tvs, ex_tvs, eq_spec, + = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig con subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) @@ -528,7 +526,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids - mk_val_arg field_name pat_arg_id + mk_val_arg field_name pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id) inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con)) -- Reconstruct with the WrapId so that unpacking happens @@ -559,11 +557,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) | otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs ; return (mkSimpleMatch [pat] wrapped_rhs) } -\end{code} - -Here is where we desugar the Template Haskell brackets and escapes +-- Here is where we desugar the Template Haskell brackets and escapes -\begin{code} -- Template Haskell stuff dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut" @@ -576,11 +571,9 @@ dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) -- Arrow notation extension dsExpr (HsProc pat cmd) = dsProcExpr pat cmd -\end{code} -Hpc Support +-- Hpc Support -\begin{code} dsExpr (HsTick tickish e) = do e' <- dsLExpr e return (Tick tickish e') @@ -597,9 +590,6 @@ dsExpr (HsBinTick ixT ixF e) = do do { ASSERT(exprType e2 `eqType` boolTy) mkBinaryTickBox ixT ixF e2 } -\end{code} - -\begin{code} -- HsSyn constructs that just shouldn't be here: dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig" @@ -617,11 +607,11 @@ dsExpr (HsDo {}) = panic "dsExpr:HsDo" findField :: [LHsRecField Id arg] -> Name -> [arg] -findField rbinds lbl +findField rbinds lbl = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds , lbl == idName (unLoc id) ] -\end{code} +{- %-------------------------------------------------------------------- Note [Desugaring explicit lists] @@ -640,10 +630,10 @@ fruitless allocations. Essentially, whenever we see a list literal say [x_1, ..., x_(k-1)], we turn it into an expression involving build so that if we find any foldrs over it it will fuse away entirely! - + So in this example we will desugar to: build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n] - + If fusion fails to occur then build will get inlined and (since we defined a RULE for foldr (:) []) we will get back exactly the normal desugaring for an explicit list. @@ -662,11 +652,11 @@ point doing this fancy stuff, and it may even be harmful. =======> Note by SLPJ Dec 08. I'm unconvinced that we should *ever* generate a build for an explicit -list. See the comments in GHC.Base about the foldr/cons rule, which +list. See the comments in GHC.Base about the foldr/cons rule, which points out that (foldr k z [a,b,c]) may generate *much* less code than (a `k` b `k` c `k` z). -Furthermore generating builds messes up the LHS of RULES. +Furthermore generating builds messes up the LHS of RULES. Example: the foldr/single rule in GHC.Base foldr k z [x] = ... We do not want to generate a build invocation on the LHS of this RULE! @@ -675,10 +665,9 @@ We fix this by disabling rules in rule LHSs, and testing that flag here; see Note [Desugaring RULE left hand sides] in Desugar To test this I've added a (static) flag -fsimple-list-literals, which -makes all list literals be generated via the simple route. +makes all list literals be generated via the simple route. +-} - -\begin{code} dsExplicitList :: PostTc Id Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr -- See Note [Desugaring explicit lists] @@ -698,7 +687,7 @@ dsExplicitList elt_ty Nothing xs is_static e = all is_static_var (varSetElems (exprFreeVars e)) is_static_var :: Var -> Bool - is_static_var v + is_static_var v | isId v = isExternalName (idName v) -- Top-level things are given external names | otherwise = False -- Type variables @@ -712,11 +701,11 @@ dsExplicitList elt_ty (Just fln) xs ; list <- dsExplicitList elt_ty Nothing xs ; dflags <- getDynFlags ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) } - + spanTail :: (a -> Bool) -> [a] -> ([a], [a]) spanTail f xs = (reverse rejected, reverse satisfying) where (satisfying, rejected) = span f $ reverse xs - + dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr dsArithSeq expr (From from) = App <$> dsExpr expr <*> dsLExpr from @@ -737,31 +726,31 @@ dsArithSeq expr (FromThenTo from thn to) thn' <- dsLExpr thn to' <- dsLExpr to return $ mkApps expr' [from', thn', to'] -\end{code} +{- Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're handled in DsListComp). Basically does the translation given in the Haskell 98 report: +-} -\begin{code} dsDo :: [ExprLStmt Id] -> DsM CoreExpr dsDo stmts = goL stmts where goL [] = panic "dsDo" goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - + go _ (LastStmt body _) stmts = ASSERT( null stmts ) dsLExpr body -- The 'return' op isn't used for 'do' expressions go _ (BodyStmt rhs then_expr _ _) stmts = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs (exprType rhs2) + ; warnDiscardedDoBindings rhs (exprType rhs2) ; then_expr2 <- dsExpr then_expr ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } - + go _ (LetStmt binds) stmts = do { rest <- goL stmts ; dsLocalBinds binds rest } @@ -777,7 +766,7 @@ dsDo stmts res1_ty (cantFailMatchResult body) ; match_code <- handle_failure pat match fail_op ; return (mkApps bind_op' [rhs', Lam var match_code]) } - + go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op @@ -785,7 +774,7 @@ dsDo stmts = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } where new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats) - mfix_app bind_op + mfix_app bind_op noSyntaxExpr -- Tuple cannot fail tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids @@ -801,9 +790,9 @@ dsDo stmts body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets) ret_stmt = noLoc $ mkLastStmt ret_app - -- This LastStmt will be desugared with dsDo, + -- This LastStmt will be desugared with dsDo, -- which ignores the return_op in the LastStmt, - -- so we must apply the return_op explicitly + -- so we must apply the return_op explicitly go _ (ParStmt {}) _ = panic "dsDo ParStmt" go _ (TransStmt {}) _ = panic "dsDo TransStmt" @@ -821,18 +810,17 @@ handle_failure pat match fail_op = extractMatchResult match (error "It can't fail") mk_fail_msg :: DynFlags -> Located e -> String -mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ +mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ showPpr dflags (getLoc pat) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Errors and contexts} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- Warn about certain types of values discarded in monadic bindings (#3263) warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () warnDiscardedDoBindings rhs rhs_ty @@ -869,4 +857,3 @@ badMonadBind rhs elt_ty flag_doc , hang (ptext (sLit "Suppress this warning by saying")) 2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs) , ptext (sLit "or by using the flag") <+> flag_doc ] -\end{code} diff --git a/compiler/deSugar/DsExpr.lhs-boot b/compiler/deSugar/DsExpr.hs-boot similarity index 92% rename from compiler/deSugar/DsExpr.lhs-boot rename to compiler/deSugar/DsExpr.hs-boot index 03a47ed41be02a5c6e74def70a7c87dacaeff5d4..129185d2387ef75493b4c12ace0c6a6b109a19b6 100644 --- a/compiler/deSugar/DsExpr.lhs-boot +++ b/compiler/deSugar/DsExpr.hs-boot @@ -1,4 +1,3 @@ -\begin{code} module DsExpr where import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) import Var ( Id ) @@ -8,4 +7,3 @@ import CoreSyn ( CoreExpr ) dsExpr :: HsExpr Id -> DsM CoreExpr dsLExpr :: LHsExpr Id -> DsM CoreExpr dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr -\end{code} diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.hs similarity index 95% rename from compiler/deSugar/DsForeign.lhs rename to compiler/deSugar/DsForeign.hs index 660cbf0231e0b937af51b25cedb2e9922c4b6462..0ae14f8d1d3b822139d98a8d4a54cc511abadfe4 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + Desugaring foreign declarations (see also DsCCall). +-} -\begin{code} {-# LANGUAGE CPP #-} module DsForeign ( dsForeigns @@ -60,8 +60,8 @@ import Hooks import Data.Maybe import Data.List -\end{code} +{- Desugaring of @foreign@ declarations is naturally split up into parts, an @import@ and an @export@ part. A @foreign import@ declaration @@ -74,8 +74,8 @@ is the same as f a1 ... an = _ccall_ nm cc a1 ... an \end{verbatim} so we reuse the desugaring code in @DsCCall@ to deal with these. +-} -\begin{code} type Binding = (Id, CoreExpr) -- No rec/nonrec structure; -- the occurrence analyser will sort it all out @@ -111,14 +111,13 @@ dsForeigns' fos = do (CExport (L _ (CExportStatic ext_nm cconv)) _)) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Foreign import} -%* * -%************************************************************************ +* * +************************************************************************ Desugaring foreign imports is just the matter of creating a binding that on its RHS unboxes its arguments, performs the external call @@ -137,8 +136,8 @@ However, we create a worker/wrapper pair, thus: The strictness/CPR analyser won't do this automatically because it doesn't look inside returned tuples; but inlining this wrapper is a Really Good Idea because it exposes the boxing to the call site. +-} -\begin{code} dsFImport :: Id -> Coercion -> ForeignImport @@ -191,16 +190,15 @@ fun_type_arg_stdcall_info dflags StdCallConv ty in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) fun_type_arg_stdcall_info _ _other_conv _ = Nothing -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Foreign calls} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) dsFCall fn_id co fcall mDeclHeader = do @@ -280,14 +278,13 @@ dsFCall fn_id co fcall mDeclHeader = do fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs' return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Primitive calls} -%* * -%************************************************************************ +* * +************************************************************************ This is for `@foreign import prim@' declarations. @@ -295,8 +292,8 @@ Currently, at the core level we pretend that these primitive calls are foreign calls. It may make more sense in future to have them as a distinct kind of Id, or perhaps to bundle them with PrimOps since semantically and for calling convention they are really prim ops. +-} -\begin{code} dsPrimCall :: Id -> Coercion -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) dsPrimCall fn_id co fcall = do @@ -317,13 +314,12 @@ dsPrimCall fn_id co fcall = do rhs' = Cast rhs co return ([(fn_id, rhs')], empty, empty) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Foreign export} -%* * -%************************************************************************ +* * +************************************************************************ The function that does most of the work for `@foreign export@' declarations. (see below for the boilerplate code a `@foreign export@' declaration expands @@ -335,8 +331,8 @@ For each `@foreign export foo@' in a module M we generate: \item a Haskell stub `@M.\$ffoo@', which calls \end{itemize} the user-written Haskell function `@M.foo@'. +-} -\begin{code} dsFExport :: Id -- Either the exported Id, -- or the foreign-export-dynamic constructor -> Coercion -- Coercion between the Haskell type callable @@ -376,8 +372,8 @@ dsFExport fn_id co ext_name cconv isDyn = do mkFExportCBits dflags ext_name (if isDyn then Nothing else Just fn_id) fe_arg_tys res_ty is_IO_res_ty cconv -\end{code} +{- @foreign import "wrapper"@ (previously "foreign export dynamic") lets you dress up Haskell IO actions of some fixed type behind an externally callable interface (i.e., as a C function pointer). Useful @@ -411,8 +407,8 @@ f_helper(StablePtr s, HsBool b, HsInt i) rts_unlock(cap); } \end{verbatim} +-} -\begin{code} dsFExportDynamic :: Id -> Coercion -> CCallConv @@ -488,19 +484,19 @@ dsFExportDynamic id co0 cconv = do toCName :: DynFlags -> Id -> String toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) -\end{code} -%* -% +{- +* + \subsection{Generating @foreign export@ stubs} -% -%* + +* For each @foreign export@ function, a C stub function is generated. The C stub constructs the application of the exported Haskell function using the hugs/ghc rts invocation API. +-} -\begin{code} mkFExportCBits :: DynFlags -> FastString -> Maybe Id -- Just==static, Nothing==dynamic @@ -814,4 +810,3 @@ primTyDescChar dflags ty | wORD_SIZE dflags == 4 = ('W','w') | wORD_SIZE dflags == 8 = ('L','l') | otherwise = panic "primTyDescChar" -\end{code} diff --git a/compiler/deSugar/DsGRHSs.lhs b/compiler/deSugar/DsGRHSs.hs similarity index 88% rename from compiler/deSugar/DsGRHSs.lhs rename to compiler/deSugar/DsGRHSs.hs index a571e807d4bf4d814c57123fcc1cc4a1abdaf3c6..1346f8af5e9648d531871c312ef9b345f29e8848 100644 --- a/compiler/deSugar/DsGRHSs.lhs +++ b/compiler/deSugar/DsGRHSs.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Matching guarded right-hand-sides (GRHSs) +-} -\begin{code} {-# LANGUAGE CPP #-} module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where @@ -30,8 +30,8 @@ import Name import Util import SrcLoc import Outputable -\end{code} +{- @dsGuarded@ is used for both @case@ expressions and pattern bindings. It desugars: \begin{verbatim} @@ -42,24 +42,22 @@ It desugars: \end{verbatim} producing an expression with a runtime error in the corner if necessary. The type argument gives the type of the @ei@. +-} -\begin{code} dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr dsGuarded grhss rhs_ty = do match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty extractMatchResult match_result error_expr -\end{code} -In contrast, @dsGRHSs@ produces a @MatchResult@. +-- In contrast, @dsGRHSs@ produces a @MatchResult@. -\begin{code} dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from -> GRHSs Id (LHsExpr Id) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult -dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty +dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = ASSERT( notNull grhss ) do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss ; let match_result1 = foldr1 combineMatchResults match_results @@ -70,16 +68,15 @@ dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty -\end{code} - -%************************************************************************ -%* * -%* matchGuard : make a MatchResult from a guarded RHS * -%* * -%************************************************************************ +{- +************************************************************************ +* * +* matchGuard : make a MatchResult from a guarded RHS * +* * +************************************************************************ +-} -\begin{code} matchGuards :: [GuardStmt Id] -- Guard -> HsStmtContext Name -- Context -> LHsExpr Id -- RHS @@ -152,10 +149,11 @@ isTrueLHsExpr (L _ (HsBinTick ixT _ e)) isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e isTrueLHsExpr _ = Nothing -\end{code} +{- Should {\em fail} if @e@ returns @D@ \begin{verbatim} f x | p <- e', let C y# = e, f y# = r1 | otherwise = r2 \end{verbatim} +-} diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.hs similarity index 95% rename from compiler/deSugar/DsListComp.lhs rename to compiler/deSugar/DsListComp.hs index 2111c95f828565921c3030e43d6224644b238490..79d6f4761241dbacbd07962fca076b26c4031868 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Desugaring list comprehensions, monad comprehensions and array comprehensions +-} -\begin{code} {-# LANGUAGE CPP, NamedFieldPuns #-} module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where @@ -35,15 +35,15 @@ import FastString import TcType import ListSetOps( getNth ) import Util -\end{code} +{- List comprehensions may be desugared in one of two ways: ``ordinary'' (as you would expect if you read SLPJ's book) and ``with foldr/build turned on'' (if you read Gill {\em et al.}'s paper on the subject). There will be at least one ``qualifier'' in the input. +-} -\begin{code} dsListComp :: [ExprLStmt Id] -> Type -- Type of entire list -> DsM CoreExpr @@ -137,13 +137,13 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM return (bound_unzipped_inner_list_expr, pat) dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions} -%* * -%************************************************************************ +* * +************************************************************************ Just as in Phil's chapter~7 in SLPJ, using the rules for optimally-compiled list comprehensions. This is what Kevin followed @@ -202,8 +202,7 @@ don't have to deal with arbitrary limits on the number of zip functions in the prelude, nor which library the zip function came from. The introduced tuples are Boxed, but only because I couldn't get it to work with the Unboxed variety. - -\begin{code} +-} deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr @@ -251,10 +250,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list pats = map mkBigLHsVarPatTup bndrs_s deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" -\end{code} - -\begin{code} deBindComp :: OutPat Id -> CoreExpr -> [ExprStmt Id] @@ -288,13 +284,13 @@ deBindComp pat core_list1 quals core_list2 = do -- Increasing order of tag return (Let (Rec [(h, rhs)]) letrec_body) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions} -%* * -%************************************************************************ +* * +************************************************************************ @dfListComp@ are the rules used with foldr/build turned on: @@ -308,8 +304,8 @@ TE[ e | p <- l , q ] c n = let in foldr f n l \end{verbatim} +-} -\begin{code} dfListComp :: Id -> Id -- 'c' and 'n' -> [ExprStmt Id] -- the rest of the qual's -> DsM CoreExpr @@ -368,15 +364,14 @@ dfBindComp c_id n_id (pat, core_list1) quals = do -- now build the outermost foldr, and return mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} mkZipBind :: [Type] -> DsM (Id, CoreExpr) -- mkZipBind [t1, t2] @@ -456,15 +451,14 @@ mkUnzipBind _ elt_tys unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[DsPArrComp]{Desugaring of array comprehensions} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} -- entry point for desugaring a parallel array comprehension -- @@ -658,11 +652,9 @@ parrElemType e = Just (tycon, [ty]) | tycon == parrTyCon -> ty _ -> panic "DsListComp.parrElemType: not a parallel array type" -\end{code} -Translation for monad comprehensions +-- Translation for monad comprehensions -\begin{code} -- Entry point for monad comprehension desugaring dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr dsMonadComp stmts = dsMcStmts stmts @@ -780,7 +772,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest } where - ds_inner (ParStmtBlock stmts bndrs return_op) + ds_inner (ParStmtBlock stmts bndrs return_op) = do { exp <- dsInnerMonadComp stmts bndrs return_op ; return (exp, mkBigCoreVarTupTy bndrs) } @@ -877,4 +869,3 @@ mkMcUnzipM _ fmap_op ys elt_tys mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } -\end{code} diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.hs similarity index 91% rename from compiler/deSugar/DsMonad.lhs rename to compiler/deSugar/DsMonad.hs index 1c707c4afcd3d60011888b686c91fe86e510eaa2..9c987a24b6f8820005d20b526874dfcce5f75222 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + @DsMonad@: monadery used in desugaring +-} -\begin{code} {-# LANGUAGE FlexibleInstances #-} module DsMonad ( @@ -19,12 +19,12 @@ module DsMonad ( newFailLocalDs, newPredVarDs, getSrcSpanDs, putSrcSpanDs, mkPrintUnqualifiedDs, - newUnique, + newUnique, UniqSupply, newUniqueSupply, getGhcModeDs, dsGetFamInstEnvs, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, - - PArrBuiltin(..), + + PArrBuiltin(..), dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe, dsInitPArrBuiltin, @@ -67,15 +67,15 @@ import Maybes import Data.IORef import Control.Monad -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Data types for the desugarer -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data DsMatchContext = DsMatchContext (HsMatchContext Name) SrcSpan deriving () @@ -110,20 +110,19 @@ data CanItFail = CanFail | CantFail orFail :: CanItFail -> CanItFail -> CanItFail orFail CantFail CantFail = CantFail orFail _ _ = CanFail -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Monad stuff -%* * -%************************************************************************ +* * +************************************************************************ Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around a @UniqueSupply@ and some annotations, which presumably include source-file location information: +-} -\begin{code} type DsM result = TcRnIf DsGblEnv DsLclEnv result -- Compatibility functions @@ -131,7 +130,7 @@ fixDs :: (a -> DsM a) -> DsM a fixDs = fixM type DsWarning = (SrcSpan, SDoc) - -- Not quite the same as a WarnMsg, we have an SDoc here + -- Not quite the same as a WarnMsg, we have an SDoc here -- and we'll do the print_unqual stuff later on to turn it -- into a Doc. @@ -154,13 +153,13 @@ data PArrBuiltin , enumFromThenToPVar :: Var -- ^ enumFromThenToP } -data DsGblEnv +data DsGblEnv = DsGblEnv { ds_mod :: Module -- For SCC profiling , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env , ds_unqual :: PrintUnqualified , ds_msgs :: IORef Messages -- Warning messages - , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, + , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things , ds_dph_env :: GlobalRdrEnv -- exported entities of 'Data.Array.Parallel.Prim' -- iff '-fvectorise' flag was given as well as @@ -177,12 +176,12 @@ data DsLclEnv = DsLclEnv { ds_loc :: SrcSpan -- to put in pattern-matching error msgs } --- Inside [| |] brackets, the desugarer looks +-- Inside [| |] brackets, the desugarer looks -- up variables in the DsMetaEnv type DsMetaEnv = NameEnv DsMetaVal data DsMetaVal - = Bound Id -- Bound by a pattern inside the [| |]. + = Bound Id -- Bound by a pattern inside the [| |]. -- Will be dynamically alpha renamed. -- The Id has type THSyntax.Var @@ -205,7 +204,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside initDPHBuiltins $ tryM thing_inside -- Catch exceptions (= errors during desugaring) - -- Display any errors and warnings + -- Display any errors and warnings -- Note: if -Werror is used, we don't signal an error here. ; msgs <- readIORef msg_var @@ -217,7 +216,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside -- a UserError exception. Then it should have put an error -- message in msg_var, so we just discard the exception - ; return (msgs, final_res) + ; return (msgs, final_res) } where -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of @@ -235,7 +234,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside -> DsM GlobalRdrEnv -- empty if condition 'False' loadOneModule modname check err = do { doLoad <- check - ; if not doLoad + ; if not doLoad then return emptyGlobalRdrEnv else do { ; result <- liftIO $ findImportedModule hsc_env modname Nothing @@ -260,7 +259,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside checkLoadDAP = do { paEnabled <- xoptM Opt_ParallelArrays ; return $ paEnabled && - mod /= gHC_PARR' && + mod /= gHC_PARR' && moduleName mod /= dATA_ARRAY_PARALLEL_NAME } -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a @@ -313,46 +312,45 @@ loadModule doc mod imp_spec = ImpDeclSpec { is_mod = name, is_qual = True, is_dloc = wiredInSrcSpan, is_as = name } name = moduleName mod -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Operations in the monad -%* * -%************************************************************************ +* * +************************************************************************ And all this mysterious stuff is so we can occasionally reach out and grab one or more names. @newLocalDs@ isn't exported---exported functions are defined with it. The difference in name-strings makes it easier to read debugging output. +-} -\begin{code} -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Id -> Type -> DsM Id newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id -duplicateLocalDs old_local +duplicateLocalDs old_local = do { uniq <- newUnique ; return (setIdUnique old_local uniq) } newPredVarDs :: PredType -> DsM Var newPredVarDs pred = newSysLocalDs pred - + newSysLocalDs, newFailLocalDs :: Type -> DsM Id newSysLocalDs = mkSysLocalM (fsLit "ds") newFailLocalDs = mkSysLocalM (fsLit "fail") newSysLocalsDs :: [Type] -> DsM [Id] newSysLocalsDs tys = mapM newSysLocalDs tys -\end{code} +{- We can also reach out and either set/grab location information from the @SrcSpan@ being carried around. +-} -\begin{code} getGhcModeDs :: DsM GhcMode getGhcModeDs = getDynFlags >>= return . ghcMode @@ -363,15 +361,15 @@ putSrcSpanDs :: SrcSpan -> DsM a -> DsM a putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside warnDs :: SDoc -> DsM () -warnDs warn = do { env <- getGblEnv +warnDs warn = do { env <- getGblEnv ; loc <- getSrcSpanDs ; dflags <- getDynFlags ; let msg = mkWarnMsg dflags loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } failWithDs :: SDoc -> DsM a -failWithDs err - = do { env <- getGblEnv +failWithDs err + = do { env <- getGblEnv ; loc <- getSrcSpanDs ; dflags <- getDynFlags ; let msg = mkErrMsg dflags loc (ds_unqual env) err @@ -380,21 +378,19 @@ failWithDs err mkPrintUnqualifiedDs :: DsM PrintUnqualified mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv -\end{code} -\begin{code} instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal dsLookupGlobal :: Name -> DsM TyThing -- Very like TcEnv.tcLookupGlobal -dsLookupGlobal name +dsLookupGlobal name = do { env <- getGblEnv ; setEnvs (ds_if_env env) (tcIfaceGlobal name) } dsLookupGlobalId :: Name -> DsM Id -dsLookupGlobalId name +dsLookupGlobalId name = tyThingId <$> dsLookupGlobal name -- |Get a name from "Data.Array.Parallel" for the desugarer, from the 'ds_parr_bi' component of the @@ -410,10 +406,6 @@ dsLookupTyCon name dsLookupDataCon :: Name -> DsM DataCon dsLookupDataCon name = tyThingDataCon <$> dsLookupGlobal name -\end{code} - -\begin{code} - -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'. -- Panic if there isn't one, or if it is defined multiple times. @@ -477,9 +469,7 @@ dsInitPArrBuiltin thing_inside externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId arithErr = panic "Arithmetic sequences have to wait until we support type classes" -\end{code} -\begin{code} dsGetFamInstEnvs :: DsM FamInstEnvs -- Gets both the external-package inst-env -- and the home-pkg inst env (includes module being compiled) @@ -496,9 +486,7 @@ dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a dsExtendMetaEnv menv thing_inside = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside -\end{code} -\begin{code} discardWarningsDs :: DsM a -> DsM a -- Ignore warnings inside the thing inside; -- used to ignore inaccessable cases etc. inside generated code @@ -512,4 +500,3 @@ discardWarningsDs thing_inside ; writeTcRef (ds_msgs env) old_msgs ; return result } -\end{code} diff --git a/compiler/deSugar/DsMonad.lhs-boot b/compiler/deSugar/DsMonad.hs-boot similarity index 97% rename from compiler/deSugar/DsMonad.lhs-boot rename to compiler/deSugar/DsMonad.hs-boot index 081b0480004d1007f2767dd48b971b6126e6ffb6..12bc5ebcf8e4767559cb0daa6d4a65933669f377 100644 --- a/compiler/deSugar/DsMonad.lhs-boot +++ b/compiler/deSugar/DsMonad.hs-boot @@ -1,4 +1,3 @@ -\begin{code} module DsMonad (DsM) where import TcRnTypes @@ -7,8 +6,7 @@ data DsGblEnv data DsLclEnv type DsM result = TcRnIf DsGblEnv DsLclEnv result -\end{code} - +{- Some notes about this boot file (from Edsko): @@ -31,3 +29,4 @@ for the dsForeignsHook.) I'm sure this cycle can be broken somehow, but I'm not familiar enough with this part of the compiler to see if there is a natural point to do it. +-} diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.hs similarity index 93% rename from compiler/deSugar/DsUtils.lhs rename to compiler/deSugar/DsUtils.hs index bd99b904ae81ddd8419ca79707ef07d9472ab549..1a7985fec37fb84d48ccdbe941e61d0d72782c62 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.hs @@ -1,13 +1,13 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Utilities for desugaring This module exports some utility functions of no great interest. +-} -\begin{code} {-# LANGUAGE CPP #-} -- | Utility functions for constructing Core syntax, principally for desugaring @@ -75,21 +75,20 @@ import FastString import TcEvidence import Control.Monad ( zipWithM ) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{ Selecting match variables} -%* * -%************************************************************************ +* * +************************************************************************ We're about to match against some patterns. We want to make some @Ids@ to use as match variables. If a pattern has an @Id@ readily at hand, which should indeed be bound to the pattern as a whole, then use it; otherwise, make one up. +-} -\begin{code} selectSimpleMatchVarL :: LPat Id -> DsM Id selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) @@ -120,8 +119,8 @@ selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise patter selectMatchVar (AsPat var _) = return (unLoc var) selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat) -- OK, better make up one... -\end{code} +{- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider module M where @@ -160,28 +159,26 @@ runs on the output of the desugarer, so all is well by the end of the desugaring pass. -%************************************************************************ -%* * -%* type synonym EquationInfo and access functions for its pieces * -%* * -%************************************************************************ +************************************************************************ +* * +* type synonym EquationInfo and access functions for its pieces * +* * +************************************************************************ \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} The ``equation info'' used by @match@ is relatively complicated and worthy of a type synonym and a few handy functions. +-} -\begin{code} firstPat :: EquationInfo -> Pat Id firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) shiftEqns :: [EquationInfo] -> [EquationInfo] -- Drop the first pattern in each equation shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ] -\end{code} -Functions on MatchResults +-- Functions on MatchResults -\begin{code} matchCanFail :: MatchResult -> Bool matchCanFail (MatchResult CanFail _) = True matchCanFail (MatchResult CantFail _) = False @@ -337,9 +334,6 @@ mkCoAlgCaseMatchResult dflags var ty match_alts mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt -\end{code} - -\begin{code} sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon] sort_alts = sortWith (dataConTag . alt_pat) @@ -450,15 +444,15 @@ mkPArrCase dflags var ty sorted_alts fail = do binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)] -- indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Desugarer's versions of some Core functions} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkErrorAppDs :: Id -- The error function -> Type -- Type to which it should be applied -> SDoc -- The error message string to pass @@ -472,8 +466,8 @@ mkErrorAppDs err_id ty msg = do core_msg = Lit (mkMachString full_msg) -- mkMachString returns a result of type String# return (mkApps (Var err_id) [Type ty, core_msg]) -\end{code} +{- 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. Note [Desugaring seq (1)] cf Trac #1031 @@ -539,8 +533,8 @@ The isLocalId ensures that we don't turn into case True of True { ... } which stupidly tries to bind the datacon 'True'. +-} -\begin{code} mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)] @@ -554,14 +548,13 @@ mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr mkCoreAppsDs fun args = foldl mkCoreAppDs fun args -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[mkSelectorBind]{Make a selector bind} -%* * -%************************************************************************ +* * +************************************************************************ This is used in various places to do with lazy patterns. For each binder $b$ in the pattern, we create a binding: @@ -604,8 +597,8 @@ Otherwise we do (B). Really (A) is just an optimisation for very common cases like Just x = e (p,q) = e +-} -\begin{code} mkSelectorBinds :: [Maybe (Tickish Id)] -- ticks to add, possibly -> LPat Id -- The pattern -> CoreExpr -- Expression to which the pattern is bound @@ -690,13 +683,13 @@ mkSelectorBinds ticks pat val_expr is_triv_pat (WildPat _) = True is_triv_pat (ParPat p) = is_triv_lpat p is_triv_pat _ = False -\end{code} +{- Creating big tuples and their types for full Haskell expressions. They work over *Ids*, and create tuples replete with their types, which is whey they are not in HsUtils. +-} -\begin{code} mkLHsPatTup :: [LPat Id] -> LPat Id mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat @@ -723,13 +716,13 @@ mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) mkBigLHsPatTup :: [LPat Id] -> LPat Id mkBigLHsPatTup = mkChunkified mkLHsPatTup -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} -%* * -%************************************************************************ +* * +************************************************************************ Generally, we handle pattern matching failure like this: let-bind a fail-variable, and use that variable if the thing fails: @@ -778,8 +771,8 @@ for the primitive case: \end{verbatim} Now @fail.33@ is a function, so it can be let-bound. +-} -\begin{code} mkFailurePair :: CoreExpr -- Result type of the whole case expression -> DsM (CoreBind, -- Binds the newly-created fail variable -- to \ _ -> expression @@ -793,8 +786,8 @@ mkFailurePair expr App (Var fail_fun_var) (Var voidPrimId)) } where ty = exprType expr -\end{code} +{- Note [Failure thunks and CPR] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we make a failure point we ensure that it @@ -812,8 +805,8 @@ entered at most once. Adding a dummy 'realWorld' token argument makes it clear that sharing is not an issue. And that in turn makes it more CPR-friendly. This matters a lot: if you don't get it right, you lose the tail call property. For example, see Trac #3403. +-} -\begin{code} mkOptTickBox :: Maybe (Tickish Id) -> CoreExpr -> CoreExpr mkOptTickBox Nothing e = e mkOptTickBox (Just tickish) e = Tick tickish e @@ -831,4 +824,3 @@ mkBinaryTickBox ixT ixF e = do [ (DataAlt falseDataCon, [], falseBox) , (DataAlt trueDataCon, [], trueBox) ] -\end{code} diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.hs similarity index 94% rename from compiler/deSugar/Match.lhs rename to compiler/deSugar/Match.hs index 753c8fda52f59a51965b7df9d2fa1f40073a640e..5089f86298524ebecbe28db98142971c0ec64788 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + The @match@ function +-} -\begin{code} {-# LANGUAGE CPP #-} module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where @@ -48,16 +48,16 @@ import FastString import Control.Monad( when ) import qualified Data.Map as Map -\end{code} +{- This function is a wrapper of @match@, it must be called from all the parts where it was called match, but only substitutes the first call, .... if the associated flags are declared, warnings will be issued. It can not be called matchWrapper because this name already exists :-( JJCQ 30-Nov-1997 +-} -\begin{code} matchCheck :: DsMatchContext -> [Id] -- Vars rep'ing the exprs we're matching with -> Type -- Type of the case expression @@ -102,21 +102,19 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs -- in list comprehensions, pattern guards -- etc. They are often *supposed* to be -- incomplete -\end{code} +{- This variable shows the maximum number of lines of output generated for warnings. It will limit the number of patterns/equations displayed to@ maximum_output@. (ToDo: add command-line option?) +-} -\begin{code} maximum_output :: Int maximum_output = 4 -\end{code} -The next two functions create the warning message. +-- The next two functions create the warning message. -\begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () dsShadowWarn ctx@(DsMatchContext kind loc) qs = putSrcSpanDs loc (warnDs warn) @@ -171,14 +169,13 @@ ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats] ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn)) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * The main matching function -%* * -%************************************************************************ +* * +************************************************************************ The function @match@ is basically the same as in the Wadler chapter, except it is monadised, to carry around the name supply, info about @@ -276,8 +273,8 @@ constructors, or all variables (or similar beasts), etc. @match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. +-} -\begin{code} match :: [Id] -- Variables rep\'ing the exprs we\'re matching with -> Type -- Type of the case expression -> [EquationInfo] -- Info about patterns, etc. (type synonym below) @@ -420,8 +417,8 @@ getViewPat (ViewPat _ pat _) = unLoc pat getViewPat _ = panic "getViewPat" getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing getOLPat _ = panic "getOLPat" -\end{code} +{- Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The list of EquationInfo can be empty, arising from @@ -440,11 +437,11 @@ case we want to see that "hello" exception, not (error "empty case"). See also Note [Case elimination: lifted case] in Simplify. -%************************************************************************ -%* * +************************************************************************ +* * Tidying patterns -%* * -%************************************************************************ +* * +************************************************************************ Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ which will be scrutinised. This means: @@ -480,8 +477,8 @@ Float, Double, at least) are converted to unboxed form; e.g., (ConPat I# _ _ [LitPat (HsIntPrim i)]) \end{verbatim} \end{description} +-} -\begin{code} tidyEqnInfo :: Id -> EquationInfo -> DsM (DsWrapper, EquationInfo) -- DsM'd because of internal call to dsLHsBinds @@ -633,7 +630,7 @@ push_bang_into_newtype_arg :: SrcSpan -> HsConPatDetails Id -> HsConPatDetails I -- See Note [Bang patterns and newtypes] -- We are transforming !(N p) into (N !p) push_bang_into_newtype_arg l (PrefixCon (arg:args)) - = ASSERT( null args) + = ASSERT( null args) PrefixCon [L l (BangPat arg)] push_bang_into_newtype_arg l (RecCon rf) | HsRecFields { rec_flds = L lf fld : flds } <- rf @@ -642,8 +639,8 @@ push_bang_into_newtype_arg l (RecCon rf) RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] }) push_bang_into_newtype_arg _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) -\end{code} +{- Note [Bang patterns and newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the pattern !(Just pat) we can discard the bang, because @@ -681,11 +678,11 @@ evaluation of \tr{e}. An alternative translation (No.~2): ] \end{verbatim} -%************************************************************************ -%* * +************************************************************************ +* * \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} -%* * -%************************************************************************ +* * +************************************************************************ We might be able to optimise unmixing when confronted by only-one-constructor-possible, of which tuples are the most notable @@ -721,11 +718,11 @@ Need to make sure the right names get bound for the variable patterns. Presumably just a variant on the constructor case (as it is now). \end{description} -%************************************************************************ -%* * -%* matchWrapper: a convenient way to call @match@ * -%* * -%************************************************************************ +************************************************************************ +* * +* matchWrapper: a convenient way to call @match@ * +* * +************************************************************************ \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} Calls to @match@ often involve similar (non-trivial) work; that work @@ -764,13 +761,13 @@ by examining one of the RHS expressions in one of the @EquationInfo@s. \item Call @match@ with all of this information! \end{enumerate} +-} -\begin{code} matchWrapper :: HsMatchContext Name -- For shadowing warning messages -> MatchGroup Id (LHsExpr Id) -- Matches being desugared -> DsM ([Id], CoreExpr) -- Results -\end{code} +{- There is one small problem with the Lambda Patterns, when somebody writes something similar to: \begin{verbatim} @@ -792,8 +789,8 @@ due to the fact that lambda patterns can have more than one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 +-} -\begin{code} matchWrapper ctxt (MG { mg_alts = matches , mg_arg_tys = arg_tys , mg_res_ty = rhs_ty @@ -828,19 +825,19 @@ matchEquations ctxt vars eqns_info rhs_ty ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc ; extractMatchResult match_result fail_expr } -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} -%* * -%************************************************************************ +* * +************************************************************************ @mkSimpleMatch@ is a wrapper for @match@ which deals with the situation where we want to match a single expression against a single pattern. It returns an expression. +-} -\begin{code} matchSimply :: CoreExpr -- Scrutinee -> HsMatchContext Name -- Match kind -> LPat Id -- Pattern it should match @@ -871,16 +868,15 @@ matchSinglePat scrut hs_ctx pat ty match_result = do { var <- selectSimpleMatchVarL pat ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result ; return (adjustMatchResult (bindNonRec var scrut) match_result') } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Pattern classification -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data PatGroup = PgAny -- Immediate match: variables, wildcards, -- lazy patterns @@ -923,17 +919,16 @@ subGroup group -- pg_map :: Map a [EquationInfo] -- Equations seen so far in reverse order of appearance -\end{code} +{- Note [Take care with pattern order] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the subGroup function we must be very careful about pattern re-ordering, Consider the patterns [ (True, Nothing), (False, x), (True, y) ] Then in bringing together the patterns for True, we must not swap the Nothing and y! +-} - -\begin{code} sameGroup :: PatGroup -> PatGroup -> Bool -- Same group means that a single case expression -- or test will suffice to match both, *and* the order @@ -1073,8 +1068,8 @@ patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of i patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList patGroup _ pat = pprPanic "patGroup" (ppr pat) -\end{code} +{- Note [Grouping overloaded literal patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ WATCH OUT! Consider @@ -1092,4 +1087,4 @@ If the first arg matches '1' but the second does not match 'True', we cannot jump to the third equation! Because the same argument might match '2'! Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. - +-} diff --git a/compiler/deSugar/Match.lhs-boot b/compiler/deSugar/Match.hs-boot similarity index 96% rename from compiler/deSugar/Match.lhs-boot rename to compiler/deSugar/Match.hs-boot index 66ecc8aba6d90c6d8de6ab001a09ec5d8f1d30cc..826f635e321be0129108580ce8ea0b8e19cd15b1 100644 --- a/compiler/deSugar/Match.lhs-boot +++ b/compiler/deSugar/Match.hs-boot @@ -1,4 +1,3 @@ -\begin{code} module Match where import Var ( Id ) import TcType ( Type ) @@ -32,4 +31,3 @@ matchSinglePat -> Type -> MatchResult -> DsM MatchResult -\end{code} diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.hs similarity index 98% rename from compiler/deSugar/MatchCon.lhs rename to compiler/deSugar/MatchCon.hs index 8377e2a7cd0a70409562d6a905b2f87f2a250dc2..b42522c3c06ca0a0038efa9907613584b29c53e0 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Pattern-matching constructors +-} -\begin{code} {-# LANGUAGE CPP #-} module MatchCon ( matchConFamily, matchPatSyn ) where @@ -31,8 +31,8 @@ import SrcLoc import DynFlags import Outputable import Control.Monad(liftM) -\end{code} +{- We are confronted with the first column of patterns in a set of equations, all beginning with constructors from one ``family'' (e.g., @[]@ and @:@ make up the @List@ ``family''). We want to generate the @@ -83,7 +83,8 @@ returned is the number of constructors in the family. The function @matchConFamily@ is concerned with this have-we-used-all-the-constructors? question; the local function @match_cons_used@ does all the real work. -\begin{code} +-} + matchConFamily :: [Id] -> Type -> [[EquationInfo]] @@ -226,8 +227,8 @@ conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) -- Important special case for C {}, which can be used for a -- datacon that isn't declared to have fields at all | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats -\end{code} +{- Note [Record patterns] ~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -286,4 +287,4 @@ Originally I tried to use (\b -> let e = d in expr2) a to do this substitution. While this is "correct" in a way, it fails Lint, because e::Ord b but d::Ord a. - +-} diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.hs similarity index 89% rename from compiler/deSugar/MatchLit.lhs rename to compiler/deSugar/MatchLit.hs index acf0b776f3c4c04b78978155d49c5b6399fc0ee2..1f54780c6dfc8f7f0cf19a7f4d5eb83ebedcf620 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Pattern-matching literal patterns +-} -\begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey @@ -50,15 +50,15 @@ import Data.Int import Data.Traversable (traverse) #endif import Data.Word -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Desugaring literals [used to be in DsExpr, but DsMeta needs it, and it's nice to avoid a loop] -%* * -%************************************************************************ +* * +************************************************************************ We give int/float literals type @Integer@ and @Rational@, respectively. The typechecker will (presumably) have put \tr{from{Integer,Rational}s} @@ -72,8 +72,8 @@ For numeric literals, we try to detect there use at a standard type [NB: down with the @App@ conversion.] See also below where we look for @DictApps@ for \tr{plusInt}, etc. +-} -\begin{code} dsLit :: HsLit -> DsM CoreExpr dsLit (HsStringPrim _ s) = return (Lit (MachStr s)) dsLit (HsCharPrim _ c) = return (Lit (MachChar c)) @@ -114,8 +114,8 @@ dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable | not rebindable , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] | otherwise = dsExpr witness -\end{code} +{- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~ The type checker tries to do this short-cutting as early as possible, but @@ -124,17 +124,17 @@ And where it's possible to generate the correct literal right away, it's much better to do so. -%************************************************************************ -%* * +************************************************************************ +* * Warnings about overflowed literals -%* * -%************************************************************************ +* * +************************************************************************ Warn about functions like toInteger, fromIntegral, that convert between one type and another when the to- and from- types are the same. Then it's probably (albeit not definitely) the identity +-} -\begin{code} warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM () warnAboutIdentities dflags (Var conv_fn) type_of_conv | wopt Opt_WarnIdentities dflags @@ -153,9 +153,7 @@ conversionNames , fromIntegralName, realToFracName ] -- We can't easily add fromIntegerName, fromRationalName, -- because they are generated by literals -\end{code} -\begin{code} warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM () warnAboutOverflowedLiterals dflags lit | wopt Opt_WarnOverflowedLiterals dflags @@ -189,8 +187,8 @@ warnAboutOverflowedLiterals dflags lit , not (xopt Opt_NegativeLiterals dflags) = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals") | otherwise = Outputable.empty -\end{code} +{- Note [Suggest NegativeLiterals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If you write @@ -200,8 +198,8 @@ it'll parse as (negate 128), and overflow. In this case, suggest NegativeLitera We get an erroneous suggestion for x = 128 but perhaps that does not matter too much. +-} -\begin{code} warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM () -- Warns about [2,3 .. 1] which returns the empty list -- Only works for integral types, not floating point @@ -248,16 +246,15 @@ getIntegralLit (OverLit { ol_val = HsIntegral _ i, ol_type = ty }) | Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc) getIntegralLit _ = Nothing -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Tidying lit pats -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tidyLitPat :: HsLit -> Pat Id -- Result has only the following HsLits: -- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim @@ -328,16 +325,15 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ tidyNPat _ over_lit mb_neg eq = NPat over_lit mb_neg eq -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Pattern matching on LitPat -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} matchLiterals :: [Id] -> Type -- Type of the whole case expression -> [[EquationInfo]] -- All PgLits @@ -410,15 +406,15 @@ litValKey (HsFractional r) False = MachFloat (fl_value r) litValKey (HsFractional r) True = MachFloat (negate (fl_value r)) litValKey (HsIsString _ s) neg = ASSERT( not neg) MachStr (fastStringToByteString s) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Pattern matching on NPat -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal = do { let NPat lit mb_neg eq_chk = firstPat eqn1 @@ -432,14 +428,13 @@ matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) ; return (mkGuardedMatchResult pred_expr match_result) } matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Pattern matching on n+k patterns -%* * -%************************************************************************ +* * +************************************************************************ For an n+k pattern, we use the various magic expressions we've been given. We generate: @@ -450,9 +445,8 @@ We generate: else \end{verbatim} +-} - -\begin{code} matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns) @@ -475,4 +469,3 @@ matchNPlusKPats (var:vars) ty (eqn1:eqns) shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns)) -\end{code}