CaseCompletion.hs 19.6 KB
Newer Older
1
2
3
4
{- |
    Module      :  $Header$
    Description :  CaseCompletion
    Copyright   :  (c) 2005       , Martin Engelke
5
                       2011 - 2015, Björn Peemöller
6
                       2015       , Jan Tikovsky
7
    License     :  OtherLicense
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
8

9
10
11
12
13
    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  non-portable (DeriveDataTypeable)

    This module expands case branches with missing constructors.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
14

15
16
17
    The MCC translates case expressions into the intermediate language
    representation (IL) without completing them (i.e. without generating
    case branches for missing contructors), because the intermediate language
18
    supports variable patterns for the fallback case.
19
    In contrast, the FlatCurry representation of patterns only allows
20
21
    literal and constructor patterns, which requires the expansion
    default branches to all missing constructors.
22
23
24
25
26
27
28
29

    This is only necessary for *rigid* case expressions, because any
    *flexible* case expression with more than one branch and a variable
    pattern is non-deterministic. In consequence, these overlapping patterns
    have already been eliminated in the pattern matching compilation
    process (see module CurryToIL).

    To summarize, this module expands all rigid case expressions.
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
30
-}
31
{-# LANGUAGE CPP #-}
Björn Peemöller 's avatar
Björn Peemöller committed
32
module Transformations.CaseCompletion (completeCase) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
33

34
35
36
#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative        ((<$>), (<*>))
#endif
37
import qualified Control.Monad.State as S   (State, evalState, gets, modify)
38
import           Data.List                  (find)
39
import           Data.Maybe                 (fromMaybe)
40
41
42
43
44

import           Curry.Base.Ident
import           Curry.Base.Position        (SrcRef)
import qualified Curry.Syntax        as CS

45
import Base.Expr
46
47
48
49
import Base.Messages                        (internalError)
import qualified Base.ScopeEnv       as SE
  (ScopeEnv, new, beginScope, insert, exists)
import Env.Interface                        (InterfaceEnv, lookupInterface)
Björn Peemöller 's avatar
Björn Peemöller committed
50
import IL
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
51
52

-- Completes case expressions by adding branches for missing constructors.
53
-- The interface environment 'iEnv' is needed to compute these constructors.
Björn Peemöller 's avatar
Björn Peemöller committed
54
completeCase :: InterfaceEnv -> Module -> Module
55
56
57
58
completeCase iEnv mdl@(Module mid is ds) = Module mid is ds'
 where ds'= S.evalState (mapM (withLocalEnv . ccDecl) ds)
                        (CCState mdl iEnv (getModuleScope mdl))

59
60
61
62
-- -----------------------------------------------------------------------------
-- Internally used state monad
-- -----------------------------------------------------------------------------

63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
data CCState = CCState
  { modul        :: Module
  , interfaceEnv :: InterfaceEnv
  , scopeEnv     :: ScopeEnv
  }

type CCM a = S.State CCState a

getModule :: CCM Module
getModule = S.gets modul

getInterfaceEnv :: CCM InterfaceEnv
getInterfaceEnv = S.gets interfaceEnv

modifyScopeEnv :: (ScopeEnv -> ScopeEnv) -> CCM ()
modifyScopeEnv f = S.modify $ \ s -> s { scopeEnv = f $ scopeEnv s }

getScopeEnv :: CCM ScopeEnv
getScopeEnv = S.gets scopeEnv

withLocalEnv :: CCM a -> CCM a
withLocalEnv act = do
  oldEnv <- getScopeEnv
  res <- act
  modifyScopeEnv $ const oldEnv
  return res

inNestedScope :: CCM a -> CCM a
91
inNestedScope act = modifyScopeEnv SE.beginScope >> act
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
92

93
-- -----------------------------------------------------------------------------
94
-- The following functions traverse an IL term searching for case expressions
95
-- -----------------------------------------------------------------------------
96

97
98
99
100
101
ccDecl :: Decl -> CCM Decl
ccDecl dd@(DataDecl        _ _ _) = return dd
ccDecl nt@(NewtypeDecl     _ _ _) = return nt
ccDecl (FunctionDecl qid vs ty e) = inNestedScope $ do
  modifyScopeEnv (flip (foldr insertIdent) vs)
102
  FunctionDecl qid vs ty <$> ccExpr e
103
104
105
106
107
108
109
ccDecl ed@(ExternalDecl  _ _ _ _) = return ed

ccExpr :: Expression -> CCM Expression
ccExpr l@(Literal       _) = return l
ccExpr v@(Variable      _) = return v
ccExpr f@(Function    _ _) = return f
ccExpr c@(Constructor _ _) = return c
110
ccExpr (Apply       e1 e2) = Apply <$> ccExpr e1 <*> ccExpr e2
111
112
ccExpr (Case    r ea e bs) = do
  e'  <- ccExpr e
113
  bs' <- mapM ccAlt bs
114
  ccCase r ea e' bs'
115
ccExpr (Or          e1 e2) = Or <$> ccExpr e1 <*> ccExpr e2
116
ccExpr (Exist         v e) = inNestedScope $ do
117
  modifyScopeEnv $ insertIdent v
118
  Exist v <$> ccExpr e
119
ccExpr (Let           b e) = inNestedScope $ do
120
  modifyScopeEnv $ insertBinding b
121
  flip Let <$> ccExpr e <*> ccBinding b
122
ccExpr (Letrec       bs e) = inNestedScope $ do
123
  modifyScopeEnv $ flip (foldr insertBinding) bs
124
125
  flip Letrec <$> ccExpr e <*> mapM ccBinding bs
ccExpr (Typed        e ty) = flip Typed ty <$> ccExpr e
126
127
128
129

ccAlt :: Alt -> CCM Alt
ccAlt (Alt p e) = inNestedScope $ do
  modifyScopeEnv $ insertConstrTerm p
130
  Alt p <$> ccExpr e
131
132

ccBinding :: Binding -> CCM Binding
133
ccBinding (Binding v e) = Binding v <$> ccExpr e
134

135
-- ---------------------------------------------------------------------------
136
137
138
-- Functions for completing case alternatives
-- ---------------------------------------------------------------------------
ccCase :: SrcRef -> Eval -> Expression -> [Alt] -> CCM Expression
139
-- flexible cases are not completed
140
141
142
143
144
145
146
147
148
ccCase r Flex  e alts     = return $ Case r Flex e alts
ccCase _ Rigid _ []       = internalError $ "CaseCompletion.ccCase: "
                                         ++ "empty alternative list"
ccCase r Rigid e as@(a:_)
  | isConstrAlt a         = completeConsAlts r Rigid e as
  | isLitAlt    a         = completeLitAlts  r Rigid e as
  | isVarAlt    a         = completeVarAlts          e as
  | otherwise             = internalError $ "CaseCompletion.ccCase: "
                                         ++ "illegal alternative list"
149

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
150
-- Completes a case alternative list which branches via constructor patterns
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
-- by adding alternatives. Thus, case expressions of the form
--     case <ce> of
--       <C_1> -> <expr_1>
--              :
--       <C_n> -> <expr_n>
--      [<var> -> <default_expr>]
-- are in general extended to
--     let x = <ce> in
--     let y = <default_expr>[<var>/x] in
--     case x of
--       <C_1>  -> <expr_1>
--               :
--       <C_n>  -> <expr_n>
--       <C'_1> -> y
--               :
--       <C'_m> -> y
-- where the C'_j are the complementary constructor patterns of the C_i,
-- @x@ and @y@ are fresh variables, and "default_expr" is the expression
-- from the first alternative containing a variable pattern. If there is no such
-- alternative, the default expression is set to the prelude function 'failed'.
-- In addition, there are a few optimizations performed to avoid the
-- construction of unnecessary let-bindings:
--   - If there are no complementary patterns, the expression remains unchanged.
--   - If there is only one complementary pattern,
--     the binding for @y@ is avoided (see @bindDefVar@).
--   - If the variable @<var>@ does not occur in the default expression,
--     the binding for @x@ is avoided (see @mkCase@).
178
completeConsAlts :: SrcRef -> Eval -> Expression -> [Alt] -> CCM Expression
179
completeConsAlts r ea ce alts = do
180
181
  mdl       <- getModule
  menv      <- getInterfaceEnv
182
183
  -- complementary constructor patterns
  complPats <- mapM genPat $ getComplConstrs mdl menv
184
               [ c | (Alt (ConstructorPattern c _) _) <- consAlts ]
185
  [v, w] <- newIdentList 2 "x"
186
187
188
189
190
191
  let me = lookupDefaultAlt v
  return $ let c = Case r ea ce consAlts
           in  case (complPats, me) of
                    ([] , _)       -> c
                    (_:_, Nothing) -> c
                    (ps , Just e') -> bindDefVar v ce w e' ps
192
  where
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
    -- existing contructor pattern alternatives
    consAlts = filter isConstrAlt alts

    -- generate a new constructor pattern
    genPat (qid, arity) = ConstructorPattern qid <$> newIdentList arity "x"

    -- default alternative, if there is one
    lookupDefaultAlt v =
        fmap (\(Alt (VariablePattern x) de) -> replaceVar x (Variable v) de)
      $ find isVarAlt alts

    -- create a binding for @v = e@ if needed
    bindDefVar v e w e' ps
        | v `elem` fv e' = mkBinding v e $ mkCase (Variable v) w e' ps
        | otherwise      = mkCase e w e' ps

    -- create a binding for @w = e'@ if needed, and a case expression
    -- @case e of { consAlts ++ (ps -> w) }@
    mkCase e w e' ps = case ps of
        [p] -> Case r ea e (consAlts ++ [Alt p e'])
        _   -> mkBinding w e'
            $ Case r ea e (consAlts ++ [Alt p (Variable w) | p <- ps])
215
216
217
218
219
220
221
222
223
224

-- If the alternatives' branches contain literal patterns, a complementary
-- constructor list cannot be generated because it would become potentially
-- infinite. Thus, function 'completeLitAlts' transforms case expressions like
--     case <ce> of
--       <lit_1> -> <expr_1>
--       <lit_2> -> <expr_2>
--                   :
--       <lit_n> -> <expr_n>
--      [<var>   -> <default_expr>]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
225
-- to
226
227
228
229
230
231
232
233
--     let x = <ce> in
--     case (v == <lit_1>) of
--       True  -> <expr_1>
--       False -> case (x == <lit_2>) of
--                  True  -> <expr_2>
--                  False -> case ...
--                                 :
--                               -> case (x == <lit_n>) of
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
234
235
--                                    True  -> <expr_n>
--                                    False -> <default_expr>
236
-- If the default expression is missing, @failed@ is used instead.
237
238
239
completeLitAlts :: SrcRef -> Eval -> Expression -> [Alt] -> CCM Expression
completeLitAlts r ea ce alts = do
  [x] <- newIdentList 1 "x"
240
  return $ mkBinding x ce $ nestedCases x alts
241
242
243
244
245
246
247
248
249
  where
  nestedCases _ []              = failedExpr
  nestedCases x (Alt p ae : as) = case p of
    LiteralPattern l  -> Case r ea (Variable x `eqExpr` Literal l)
                          [ Alt truePatt  ae
                          , Alt falsePatt (nestedCases x as)
                          ]
    VariablePattern v -> replaceVar v (Variable x) ae
    _ -> internalError "CaseCompletion.completeLitAlts: illegal alternative"
250
251
252
253
254
255
256
257

-- For the unusual case of only one alternative containing a variable pattern,
-- it is necessary to tranform it to a 'let' term because FlatCurry does not
-- support variable patterns in case alternatives. So the case expression
--    case <ce> of
--      x -> <ae>
-- is transformed to
--      let x = <ce> in <ae>
258
259
completeVarAlts :: Expression -> [Alt] -> CCM Expression
completeVarAlts _  []             = return failedExpr
260
completeVarAlts ce (Alt p ae : _) = case p of
261
  VariablePattern x -> return $ mkBinding x ce ae
262
263
  _                 -> internalError $
    "CaseCompletion.completeVarAlts: variable pattern expected"
264
265

-- ---------------------------------------------------------------------------
266
-- Some functions for testing case alternatives
267
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
268
269

isVarAlt :: Alt -> Bool
270
271
isVarAlt (Alt (VariablePattern _) _) = True
isVarAlt _                           = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
272
273

isConstrAlt :: Alt -> Bool
274
275
isConstrAlt (Alt (ConstructorPattern _ _) _) = True
isConstrAlt _                                = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
276
277

isLitAlt :: Alt -> Bool
278
279
isLitAlt (Alt (LiteralPattern _) _) = True
isLitAlt _                          = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
280

281
282
283
284
285
286
287
-- Smart constructor for non-recursive let-binding. @mkBinding v e e'@
-- evaluates to @e'[v/e]@ if @e@ is a variable, or @let v = e in e'@ otherwise.
mkBinding :: Ident -> Expression -> Expression -> Expression
mkBinding v e e' = case e of
  Variable _ -> replaceVar v e e'
  _          -> Let (Binding v e) e'

288
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
289
290
291
292
293
-- This part of the module contains functions for replacing variables
-- with expressions. This is necessary in the case of having a default
-- alternative like
--      v -> <expr>
-- where the variable v occurs in the default expression <expr>. When
294
-- building additional alternatives for this default expression, the variable
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
295
296
-- must be replaced with the newly generated constructors.
replaceVar :: Ident -> Expression -> Expression -> Expression
297
298
299
replaceVar v e x@(Variable    w)
  | v == w    = e
  | otherwise = x
300
301
302
303
304
305
replaceVar v e (Apply     e1 e2)
  = Apply (replaceVar v e e1) (replaceVar v e e2)
replaceVar v e (Case r ev e' bs)
  = Case r ev (replaceVar v e e') (map (replaceVarInAlt v e) bs)
replaceVar v e (Or        e1 e2)
  = Or (replaceVar v e e1) (replaceVar v e e2)
306
replaceVar v e (Exist      w e')
307
308
309
310
311
312
   | v == w                        = Exist w e'
   | otherwise                     = Exist w (replaceVar v e e')
replaceVar v e (Let        b e')
   | v `occursInBinding` b         = Let b e'
   | otherwise                     = Let (replaceVarInBinding v e b)
                                         (replaceVar v e e')
313
replaceVar v e (Letrec    bs e')
314
   | any (occursInBinding v) bs = Letrec bs e'
315
316
   | otherwise                     = Letrec (map (replaceVarInBinding v e) bs)
                                            (replaceVar v e e')
317
replaceVar _ _ e'               = e'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
318
319

replaceVarInAlt :: Ident -> Expression -> Alt -> Alt
320
replaceVarInAlt v e (Alt p e')
321
322
  | v `occursInPattern` p = Alt p e'
  | otherwise             = Alt p (replaceVar v e e')
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
323
324

replaceVarInBinding :: Ident -> Expression -> Binding -> Binding
325
326
327
replaceVarInBinding v e (Binding w e')
  | v == w    = Binding w e'
  | otherwise = Binding w (replaceVar v e e')
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
328

329
330
331
332
occursInPattern :: Ident -> ConstrTerm -> Bool
occursInPattern v (VariablePattern       w) = v == w
occursInPattern v (ConstructorPattern _ vs) = v `elem` vs
occursInPattern _ _                         = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
333

334
335
occursInBinding :: Ident -> Binding -> Bool
occursInBinding v (Binding w _) = v == w
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
336

337
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
338
339
340
341
342
343
-- The following functions generate several IL expressions and patterns

failedExpr :: Expression
failedExpr = Function (qualifyWith preludeMIdent (mkIdent "failed")) 0

eqExpr :: Expression -> Expression -> Expression
344
345
eqExpr e1 e2 = Apply (Apply eq e1) e2
  where eq = Function (qualifyWith preludeMIdent (mkIdent "==")) 2
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
346
347
348
349
350
351
352

truePatt :: ConstrTerm
truePatt = ConstructorPattern qTrueId []

falsePatt :: ConstrTerm
falsePatt = ConstructorPattern qFalseId []

353
354
355
356
357
358
359
360
361
-- ---------------------------------------------------------------------------
-- The following functions compute the missing constructors for generating
-- missing case alternatives

-- Computes the complementary constructors for a given list of constructors.
-- All specified constructors must be of the same type.
-- This functions uses the module environment 'menv', which contains all
-- imported constructors, except for the built-in list constructors.
-- TODO: Check if the list constructors are in the menv.
Björn Peemöller 's avatar
Björn Peemöller committed
362
getComplConstrs :: Module -> InterfaceEnv -> [QualIdent] -> [(QualIdent, Int)]
363
364
365
366
367
368
369
370
371
372
373
getComplConstrs _                 _    []
  = internalError "CaseCompletion.getComplConstrs: empty constructor list"
getComplConstrs (Module mid _ ds) menv cs@(c:_)
  -- built-in lists
  | c `elem` [qNilId, qConsId] = complementary cs [(qNilId, 0), (qConsId, 2)]
  -- current module
  | mid' == mid                = getCCFromDecls cs ds
  -- imported module
  | otherwise                  = maybe [] (getCCFromIDecls mid' cs)
                                          (lookupInterface mid' menv)
  where mid' = fromMaybe mid (qidModule c)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
374
375
376

-- Find complementary constructors within the declarations of the
-- current module
377
378
getCCFromDecls :: [QualIdent] -> [Decl] -> [(QualIdent, Int)]
getCCFromDecls cs ds = complementary cs cinfos
379
  where
380
381
  cinfos = map constrInfo
         $ maybe [] extractConstrDecls (find (`declares` head cs) ds)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
382

383
384
385
386
  decl `declares` qid = case decl of
    DataDecl    _ _ cs' -> any (`declaresConstr` qid) cs'
    NewtypeDecl _ _ nc  -> nc `declaresConstr` qid
    _                   -> False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
387

388
  declaresConstr (ConstrDecl cid _) qid = cid == qid
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
389

390
391
  extractConstrDecls (DataDecl _ _ cs') = cs'
  extractConstrDecls _                  = []
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
392

393
  constrInfo (ConstrDecl cid tys) = (cid, length tys)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
394
395

-- Find complementary constructors within the module environment
396
getCCFromIDecls :: ModuleIdent -> [QualIdent] -> CS.Interface -> [(QualIdent, Int)]
397
getCCFromIDecls mid cs (CS.Interface _ _ ds) = complementary cs cinfos
398
  where
399
400
  cinfos = map constrInfo
         $ maybe [] extractConstrDecls (find (`declares` head cs) ds)
401

402
  decl `declares` qid = case decl of
403
404
405
    CS.IDataDecl    _ _ _ cs' _ -> any (`declaresConstr` qid) cs'
    CS.INewtypeDecl _ _ _ nc  _ -> isNewConstrDecl qid nc
    _                           -> False
406

407
408
  declaresConstr (CS.ConstrDecl  _ _ cid _) qid = unqualify qid == cid
  declaresConstr (CS.ConOpDecl _ _ _ oid _) qid = unqualify qid == oid
409
  declaresConstr (CS.RecordDecl  _ _ cid _) qid = unqualify qid == cid
410

411
  isNewConstrDecl qid (CS.NewConstrDecl _ _ cid _) = unqualify qid == cid
412
  isNewConstrDecl qid (CS.NewRecordDecl _ _ cid _) = unqualify qid == cid
413

414
415
  extractConstrDecls (CS.IDataDecl _ _ _ cs' _) = cs'
  extractConstrDecls _                          = []
416

417
418
  constrInfo (CS.ConstrDecl _ _ cid tys) = (qualifyWith mid cid, length tys)
  constrInfo (CS.ConOpDecl  _ _ _ oid _) = (qualifyWith mid oid, 2)
419
420
  constrInfo (CS.RecordDecl _ _ cid  fs) = (qualifyWith mid cid, length labels)
    where labels = [l | CS.FieldDecl _ ls _ <- fs, l <- ls]
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
421
422

-- Compute complementary constructors
423
424
complementary :: [QualIdent] -> [(QualIdent, Int)] -> [(QualIdent, Int)]
complementary known others = filter ((`notElem` known) . fst) others
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
425

426
-- ---------------------------------------------------------------------------
427
-- ScopeEnv stuff
428
429
-- ---------------------------------------------------------------------------

430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
-- Type for representing an environment containing identifiers in several
-- scope levels
type ScopeEnv = SE.ScopeEnv (Either String Integer) ()

insertIdent :: Ident -> ScopeEnv -> ScopeEnv
insertIdent i = SE.insert (Left  (idName   i)) ()
              . SE.insert (Right (idUnique i)) ()

newIdentList :: Int -> String -> CCM [Ident]
newIdentList num str = genIdentList num (0 :: Integer)
  where
  -- Generates a list of new identifiers where each identifier has
  -- the prefix 'name' followed by an index (i.e., "var3" if 'name' was "var").
  -- All returned identifiers are unique within the current scope.
  genIdentList s i
    | s == 0    = return []
    | otherwise = do
      env <- getScopeEnv
      case genIdent (str ++ show i) env of
        Nothing    -> genIdentList s (i + 1)
        Just ident -> do
          modifyScopeEnv $ insertIdent ident
          idents <- genIdentList (s - 1) (i + 1)
          return (ident : idents)

  -- Generates a new identifier for the specified name. The new identifier is
  -- unique within the current scope. If no identifier can be generated for
  -- 'name', then 'Nothing' will be returned
  genIdent n env | SE.exists (Left  n) env = Nothing
                 | otherwise               = Just (try 0)
    where try i  | SE.exists (Right i) env = try (i + 1)
                 | otherwise               = renameIdent (mkIdent n) i

463
getModuleScope :: Module -> ScopeEnv
464
getModuleScope (Module _ _ ds) = foldr insertDecl SE.new ds
465

466
467
468
469
470
471
472
insertDecl :: Decl -> ScopeEnv -> ScopeEnv
insertDecl (DataDecl      qid _ cs) = flip (foldr insertConstrDecl) cs
                                    . insertQIdent qid
insertDecl (NewtypeDecl    qid _ c) = insertConstrDecl c
                                    . insertQIdent qid
insertDecl (FunctionDecl qid _ _ _) = insertQIdent qid
insertDecl (ExternalDecl qid _ _ _) = insertQIdent qid
473

474
475
insertConstrDecl :: ConstrDecl a -> ScopeEnv -> ScopeEnv
insertConstrDecl (ConstrDecl qid _) = insertQIdent qid
476

477
478
479
480
insertConstrTerm :: ConstrTerm -> ScopeEnv -> ScopeEnv
insertConstrTerm (LiteralPattern        _) = id
insertConstrTerm (ConstructorPattern _ vs) = flip (foldr insertIdent) vs
insertConstrTerm (VariablePattern       v) = insertIdent v
481

482
483
insertBinding :: Binding -> ScopeEnv -> ScopeEnv
insertBinding (Binding v _) = insertIdent v
484

485
486
insertQIdent :: QualIdent -> ScopeEnv -> ScopeEnv
insertQIdent q = insertIdent (unqualify q)