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

8
9
10
11
12
    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
13

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
    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
    supports variable patterns.
    In contrast, the FlatCurry representation of patterns only allows
    literal and constructor patterns, which requires the expansion of
    missing or default branches to all missing constructors.

    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
29
-}
Björn Peemöller 's avatar
Björn Peemöller committed
30
module Transformations.CaseCompletion (completeCase) where
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
31

32
33
import           Control.Monad              (liftM, liftM2)
import qualified Control.Monad.State as S   (State, evalState, gets, modify)
34
import           Data.List                  (find)
35
36
37
38
39
40
41
42
43
44
import           Data.Maybe                 (catMaybes, fromMaybe)

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

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
45
import IL
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
46
47

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

54
55
56
57
-- -----------------------------------------------------------------------------
-- Internally used state monad
-- -----------------------------------------------------------------------------

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
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
86
inNestedScope act = modifyScopeEnv SE.beginScope >> act
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
87

88
-- -----------------------------------------------------------------------------
89
-- The following functions traverse an IL term searching for case expressions
90
-- -----------------------------------------------------------------------------
91

92
93
94
95
96
97
98
99
100
101
102
103
104
105
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)
  FunctionDecl qid vs ty `liftM` ccExpr e
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
ccExpr (Apply       e1 e2) = liftM2 Apply (ccExpr e1) (ccExpr e2)
106
107
ccExpr (Case    r ea e bs) = do
  e'  <- ccExpr e
108
  bs' <- mapM ccAlt bs
109
  ccCase r ea e' bs'
110
111
ccExpr (Or          e1 e2) = liftM2 Or (ccExpr e1) (ccExpr e2)
ccExpr (Exist         v e) = inNestedScope $ do
112
113
  modifyScopeEnv $ insertIdent v
  Exist v `liftM` ccExpr e
114
ccExpr (Let           b e) = inNestedScope $ do
115
116
  modifyScopeEnv $ insertBinding b
  liftM2 (flip Let) (ccExpr e) (ccBinding b)
117
ccExpr (Letrec       bs e) = inNestedScope $ do
118
119
  modifyScopeEnv $ flip (foldr insertBinding) bs
  liftM2 (flip Letrec) (ccExpr e) (mapM ccBinding bs)
120
ccExpr (Typed        e ty) = flip Typed ty `liftM` ccExpr e
121
122
123
124
125
126
127
128

ccAlt :: Alt -> CCM Alt
ccAlt (Alt p e) = inNestedScope $ do
  modifyScopeEnv $ insertConstrTerm p
  Alt p `liftM` ccExpr e

ccBinding :: Binding -> CCM Binding
ccBinding (Binding v e) = Binding v `liftM` ccExpr e
129

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

Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
146
147
148
149
150
151
152
-- Completes a case alternative list which branches via constructor patterns
-- by adding alternatives of the form
--
--      comp_pattern -> default_expr
--
-- where "comp_pattern" is a complementary constructor pattern and
-- "default_expr" is the expression from the first alternative containing
153
-- a variable pattern. If there is no such alternative, the default expression
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
154
155
156
157
-- is set to the prelude function 'failed'.
--
-- This funtions uses a scope environment ('ScopeEnv') to generate fresh
-- variables for the arguments of the new constructors.
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
completeConsAlts :: SrcRef -> Eval -> Expression -> [Alt] -> CCM Expression
completeConsAlts r ea expr alts = do
  mdl       <- getModule
  menv      <- getInterfaceEnv
  -- complementary constructors
  complCons <- mapM genConstrTerm $ getComplConstrs mdl menv
               [ c | (Alt (ConstructorPattern c _) _) <- consAlts ]
  -- complementary alternatives
  let complAlts = map (\c -> Alt c $ replaceVar v (pattern2Expr c) de)
                  complCons
  return $ Case r ea expr (consAlts ++ complAlts)
  where
  -- existing contructor pattern alternatives
  consAlts = filter isConstrAlt alts

  -- default alternative
  -- Note: the newly generated variable 'x!' is just a dummy and will never
  -- occur in the transformed program
  (Alt (VariablePattern v) de)
    = fromMaybe (Alt (VariablePattern (mkIdent "x!")) failedExpr)
    $ find isVarAlt alts

180
181
182
183
184
185
186
187
188
189
190
191
  genConstrTerm (qid, arity)
    = ConstructorPattern qid `liftM` newIdentList arity "x"

-- 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
192
-- to
193
194
195
196
197
198
199
200
--     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
201
202
--                                    True  -> <expr_n>
--                                    False -> <default_expr>
203
204
205
206
207
208
209
210
211
212
213
214
215
completeLitAlts :: SrcRef -> Eval -> Expression -> [Alt] -> CCM Expression
completeLitAlts r ea ce alts = do
  [x] <- newIdentList 1 "x"
  return $ Let (Binding x ce) $ nestedCases x alts
  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"
216
217
218
219
220
221
222
223

-- 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>
224
225
completeVarAlts :: Expression -> [Alt] -> CCM Expression
completeVarAlts _  []             = return failedExpr
226
completeVarAlts ce (Alt p ae : _) = case p of
227
  VariablePattern x -> return $ Let (Binding x ce) ae
228
229
  _                 -> internalError $
    "CaseCompletion.completeVarAlts: variable pattern expected"
230
231

-- ---------------------------------------------------------------------------
232
-- Some functions for testing case alternatives
233
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
234
235

isVarAlt :: Alt -> Bool
236
237
isVarAlt (Alt (VariablePattern _) _) = True
isVarAlt _                           = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
238
239

isConstrAlt :: Alt -> Bool
240
241
isConstrAlt (Alt (ConstructorPattern _ _) _) = True
isConstrAlt _                                = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
242
243

isLitAlt :: Alt -> Bool
244
245
isLitAlt (Alt (LiteralPattern _) _) = True
isLitAlt _                          = False
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
246

247
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
248
249
250
251
252
-- 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
253
-- building additional alternatives for this default expression, the variable
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
254
255
-- must be replaced with the newly generated constructors.
replaceVar :: Ident -> Expression -> Expression -> Expression
256
257
258
replaceVar v e x@(Variable    w)
  | v == w    = e
  | otherwise = x
259
260
261
262
263
264
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)
265
replaceVar v e (Exist      w e')
266
267
268
269
270
271
   | 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')
272
replaceVar v e (Letrec    bs e')
273
   | any (occursInBinding v) bs = Letrec bs e'
274
275
   | otherwise                     = Letrec (map (replaceVarInBinding v e) bs)
                                            (replaceVar v e e')
276
replaceVar _ _ e'               = e'
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
277
278

replaceVarInAlt :: Ident -> Expression -> Alt -> Alt
279
replaceVarInAlt v e (Alt p e')
280
281
  | v `occursInPattern` p = Alt p e'
  | otherwise             = Alt p (replaceVar v e e')
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
282
283

replaceVarInBinding :: Ident -> Expression -> Binding -> Binding
284
285
286
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
287

288
289
290
291
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
292

293
294
occursInBinding :: Ident -> Binding -> Bool
occursInBinding v (Binding w _) = v == w
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
295

296
-- ---------------------------------------------------------------------------
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
297
298
299
300
301
302
-- The following functions generate several IL expressions and patterns

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

eqExpr :: Expression -> Expression -> Expression
303
304
eqExpr e1 e2 = Apply (Apply eq e1) e2
  where eq = Function (qualifyWith preludeMIdent (mkIdent "==")) 2
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
305
306
307
308
309
310
311

truePatt :: ConstrTerm
truePatt = ConstructorPattern qTrueId []

falsePatt :: ConstrTerm
falsePatt = ConstructorPattern qFalseId []

312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
pattern2Expr :: ConstrTerm -> Expression
pattern2Expr (LiteralPattern        l) = Literal l
pattern2Expr (VariablePattern       v) = Variable v
pattern2Expr (ConstructorPattern c ts) = foldl Apply
  (Constructor c (length ts)) (map Variable ts)

-- ---------------------------------------------------------------------------
-- 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
327
getComplConstrs :: Module -> InterfaceEnv -> [QualIdent] -> [(QualIdent, Int)]
328
329
330
331
332
333
334
335
336
337
338
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
339
340
341

-- Find complementary constructors within the declarations of the
-- current module
342
343
getCCFromDecls :: [QualIdent] -> [Decl] -> [(QualIdent, Int)]
getCCFromDecls cs ds = complementary cs cinfos
344
  where
345
346
  cinfos = map constrInfo
         $ maybe [] extractConstrDecls (find (`declares` head cs) ds)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
347

348
349
350
351
  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
352

353
  declaresConstr (ConstrDecl cid _) qid = cid == qid
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
354

355
356
  extractConstrDecls (DataDecl _ _ cs') = cs'
  extractConstrDecls _                  = []
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
357

358
  constrInfo (ConstrDecl cid tys) = (cid, length tys)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
359
360

-- Find complementary constructors within the module environment
361
getCCFromIDecls :: ModuleIdent -> [QualIdent] -> CS.Interface -> [(QualIdent, Int)]
362
getCCFromIDecls mid cs (CS.Interface _ _ ds) = complementary cs cinfos
363
  where
364
365
  cinfos = map constrInfo
         $ maybe [] extractConstrDecls (find (`declares` head cs) ds)
366

367
368
  decl `declares` qid = case decl of
    CS.IDataDecl    _ _ _ cs' -> any (`declaresConstr` qid) $ catMaybes cs'
369
    CS.INewtypeDecl _ _ _ nc  -> isNewConstrDecl qid nc
370
    _                         -> False
371

372
373
  declaresConstr (CS.ConstrDecl  _ _ cid _) qid = unqualify qid == cid
  declaresConstr (CS.ConOpDecl _ _ _ oid _) qid = unqualify qid == oid
374

375
  isNewConstrDecl qid (CS.NewConstrDecl _ _ cid _) = unqualify qid == cid
376

377
378
  extractConstrDecls (CS.IDataDecl _ _ _ cs') = catMaybes cs'
  extractConstrDecls _                        = []
379

380
381
  constrInfo (CS.ConstrDecl _ _ cid tys) = (qualifyWith mid cid, length tys)
  constrInfo (CS.ConOpDecl  _ _ _ oid _) = (qualifyWith mid oid, 2)
Bjoern Peemoeller's avatar
Bjoern Peemoeller committed
382
383

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

387
-- ---------------------------------------------------------------------------
388
-- ScopeEnv stuff
389
390
-- ---------------------------------------------------------------------------

391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
-- 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

424
getModuleScope :: Module -> ScopeEnv
425
getModuleScope (Module _ _ ds) = foldr insertDecl SE.new ds
426

427
428
429
430
431
432
433
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
434

435
436
insertConstrDecl :: ConstrDecl a -> ScopeEnv -> ScopeEnv
insertConstrDecl (ConstrDecl qid _) = insertQIdent qid
437

438
439
440
441
insertConstrTerm :: ConstrTerm -> ScopeEnv -> ScopeEnv
insertConstrTerm (LiteralPattern        _) = id
insertConstrTerm (ConstructorPattern _ vs) = flip (foldr insertIdent) vs
insertConstrTerm (VariablePattern       v) = insertIdent v
442

443
444
insertBinding :: Binding -> ScopeEnv -> ScopeEnv
insertBinding (Binding v _) = insertIdent v
445

446
447
insertQIdent :: QualIdent -> ScopeEnv -> ScopeEnv
insertQIdent q = insertIdent (unqualify q)
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492

-- DEACTIVATED, as the CurryToIL transformation should already have
-- eliminated redundant alternatives.

-- The function 'removeRedundantAlts' removes case branches which are
-- either unreachable or multiply declared.
-- Note: unlike the PAKCS frontend, MCC does not support warnings. So
-- there will be no messages if alternatives have been removed.
-- removeRedundantAlts :: [Alt] -> [Alt]
-- removeRedundantAlts = removeMultipleAlts . removeIdleAlts

-- An alternative is idle if it occurs anywhere behind another alternative
-- which contains a variable pattern. Example:
--    case x of
--      (y:ys) -> e1
--      z      -> e2
--      []     -> e3
-- Here all alternatives behind (z  -> e2) are idle and will be removed.
-- removeIdleAlts ::[Alt] -> [Alt]
-- removeIdleAlts = fst . splitAfter isVarAlt
--   where
--   -- Splits a list behind the first element which satifies 'p'
--   splitAfter :: (a -> Bool) -> [a] -> ([a], [a])
--   splitAfter p xs = go [] xs
--     where
--     go fs []                 = (reverse fs    , [])
--     go fs (y:ys) | p y       = (reverse (y:fs), ys)
--                  | otherwise = go (y:fs) ys

-- An alternative occurs multiply if at least two alternatives
-- use the same pattern. Example:
--    case x of
--      []     -> e1
--      (y:ys) -> e2
--      []     -> e3
-- Here, the last alternative occures multiply because its pattern is already
-- used in the first alternative. All multiple alternatives will be
-- removed except for the first occurrence.
-- removeMultipleAlts :: [Alt] -> [Alt]
-- removeMultipleAlts = nubBy eqAlt where
--   eqAlt (Alt p1 _) (Alt p2 _) = case (p1, p2) of
--     (LiteralPattern       l1, LiteralPattern       l2) -> l1 == l2
--     (ConstructorPattern c1 _, ConstructorPattern c2 _) -> c1 == c2
--     (VariablePattern       _, VariablePattern       _) -> True
--     _                                                  -> False