module DsUtils (
EquationInfo(..),
firstPat, shiftEqns,
-
+
mkDsLet, mkDsLets,
MatchResult(..), CanItFail(..),
cantFailMatchResult, alwaysFailMatchResult,
extractMatchResult, combineMatchResults,
adjustMatchResult, adjustMatchResultDs,
- mkCoLetMatchResult,
- mkGuardedMatchResult,
+ mkCoLetMatchResult, mkGuardedMatchResult,
+ matchCanFail,
mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
wrapBind, wrapBinds,
mkTupleType, mkTupleCase, mkBigCoreTup,
mkCoreTup, mkCoreTupTy,
- dsReboundNames, lookupReboundName,
+ dsSyntaxTable, lookupEvidence,
selectSimpleMatchVarL, selectMatchVars
) where
plusIntegerName, timesIntegerName, smallIntegerDataConName,
lengthPName, indexPName )
import Outputable
-import UnicodeUtil ( intsToUtf8 )
import SrcLoc ( Located(..), unLoc )
-import Util ( isSingleton, notNull, zipEqual, sortWith )
+import Util ( isSingleton, zipEqual, sortWith )
import ListSetOps ( assocDefault )
import FastString
+import Data.Char ( ord )
+
+#ifdef DEBUG
+import Util ( notNull ) -- Used in an assertion
+#endif
\end{code}
%************************************************************************
\begin{code}
-dsReboundNames :: ReboundNames Id
+dsSyntaxTable :: SyntaxTable Id
-> DsM ([CoreBind], -- Auxiliary bindings
[(Name,Id)]) -- Maps the standard name to its value
-dsReboundNames rebound_ids
+dsSyntaxTable rebound_ids
= mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) ->
return (concat binds_s, prs)
where
newSysLocalDs (exprType rhs) `thenDs` \ id ->
return ([NonRec id rhs], (std_name, id))
-lookupReboundName :: [(Name,Id)] -> Name -> CoreExpr
-lookupReboundName prs std_name
- = Var (assocDefault (mk_panic std_name) prs std_name)
+lookupEvidence :: [(Name, Id)] -> Name -> Id
+lookupEvidence prs std_name
+ = assocDefault (mk_panic std_name) prs std_name
where
- mk_panic std_name = pprPanic "dsReboundNames" (ptext SLIT("Not found:") <+> ppr std_name)
+ mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
\end{code}
Functions on MatchResults
\begin{code}
+matchCanFail :: MatchResult -> Bool
+matchCanFail (MatchResult CanFail _) = True
+matchCanFail (MatchResult CantFail _) = False
+
alwaysFailMatchResult :: MatchResult
alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
-- Stuff for parallel arrays
--
- -- * the following is to desugar cases over fake constructors for
+ -- * the following is to desugar cases over fake constructors for
-- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
-- case
--
-- Concerning `isPArrFakeAlts':
--
- -- * it is *not* sufficient to just check the type of the type
+ -- * it is *not* sufficient to just check the type of the type
-- constructor, as we have to be careful not to confuse the real
-- representation of parallel arrays with the fake constructors;
-- moreover, a list of alternatives must not mix fake and real
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
core_msg = Lit (mkStringLit full_msg)
+ -- mkStringLit returns a result of type String#
in
returnDs (mkApps (Var err_id) [Type ty, core_msg])
\end{code}
mkStringExpr str = mkStringExprFS (mkFastString str)
mkStringExprFS str
- | nullFastString str
+ | nullFS str
= returnDs (mkNilExpr charTy)
| lengthFS str == 1
in
returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
- | all safeChar int_chars
+ | all safeChar chars
= dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id ->
returnDs (App (Var unpack_id) (Lit (MachStr str)))
| otherwise
= dsLookupGlobalId unpackCStringUtf8Name `thenDs` \ unpack_id ->
- returnDs (App (Var unpack_id) (Lit (MachStr (mkFastString (intsToUtf8 int_chars)))))
+ returnDs (App (Var unpack_id) (Lit (MachStr str)))
where
- int_chars = unpackIntFS str
- safeChar c = c >= 1 && c <= 0xFF
+ chars = unpackFS str
+ safeChar c = ord c >= 1 && ord c <= 0x7F
\end{code}