Desugar.hs 47.2 KB
Newer Older
1
{- |
2
3
4
5
6
  Module      :  $Header$
  Description :  Desugaring Curry Expressions
  Copyright   :  (c) 2001 - 2004 Wolfgang Lux
                                 Martin Engelke
                     2011 - 2015 Björn Peemöller
7
                     2015        Jan Tikovsky
8
                     2016 - 2017 Finn Teegen
9
  License     :  BSD-3-clause
10
11
12
13
14

  Maintainer  :  bjp@informatik.uni-kiel.de
  Stability   :  experimental
  Portability :  portable

15
16
  The desugaring pass removes all syntactic sugar from the module.
  In particular, the output of the desugarer will have the following
17
18
  properties.

19
20
21
22
  * No guarded right hand sides occur in equations, pattern declarations,
    and case alternatives. In addition, the declaration lists (`where`-blocks)
    of the right hand sides are empty; local declarations are transformed
    into let expressions.
23
24
25
26
27

  * Patterns in equations and case alternatives are composed only of
    - literals,
    - variables,
    - constructor applications, and
28
    - as patterns applied to literals or constructor applications.
29
30
31
32
33
34

  * Expressions are composed only of
    - literals,
    - variables,
    - constructors,
    - (binary) applications,
35
    - case expressions,
36
    - let expressions, and
37
    - expressions with a type signature.
38
39

  * Functional patterns are replaced by variables and are integrated
40
    in a guarded right hand side using the (=:<=) operator.
41

42
43
44
45
46
47
48
49
50
  * Records are transformed into ordinary data types by removing the fields.
    Record construction and pattern matching are represented using solely the
    record constructor. Record selections are represented using selector
    functions which are generated for each record declaration, and record
    updated are represented using case-expressions that perform the update.

  * The type environment will be extended by new function declarations for:
    - Record selections, and
    - Converted lambda expressions.
51
52
53

  As we are going to insert references to real prelude entities,
  all names must be properly qualified before calling this module.
54
-}
55
{-# LANGUAGE CPP #-}
56
57
module Transformations.Desugar (desugar) where

58
#if __GLASGOW_HASKELL__ < 710
59
import           Control.Applicative        ((<$>), (<*>))
60
#endif
61
import           Control.Arrow              (first, second)
Finn Teegen's avatar
Finn Teegen committed
62
import           Control.Monad              (liftM2)
Finn Teegen's avatar
Finn Teegen committed
63
import           Control.Monad.Extra        (concatMapM)
64
import qualified Control.Monad.State as S   (State, runState, gets, modify)
65
import           Data.Foldable              (foldrM)
Finn Teegen's avatar
Finn Teegen committed
66
67
import           Data.List                  ( (\\), elemIndex, nub, partition
                                            , tails )
68
import           Data.Maybe                 (fromMaybe)
69
70
71
72
73
74
75
import qualified Data.Set            as Set (Set, empty, member, insert)

import Curry.Base.Ident
import Curry.Base.Position hiding (first)
import Curry.Syntax

import Base.Expr
Finn Teegen's avatar
Finn Teegen committed
76
import Base.CurryTypes
77
import Base.Messages (internalError)
Finn Teegen's avatar
Finn Teegen committed
78
import Base.TypeExpansion
79
import Base.Types
Finn Teegen's avatar
Finn Teegen committed
80
import Base.TypeSubst
81
import Base.Typing
Finn Teegen's avatar
Finn Teegen committed
82
import Base.Utils (fst3, mapAccumM)
83

Finn Teegen's avatar
Finn Teegen committed
84
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTypeInfo)
85
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
86

87
88
89
90
-- The desugaring phase keeps only the type, function, and value
-- declarations of the module, i.e., type signatures are discarded.
-- While record declarations are transformed into ordinary data/newtype
-- declarations, the remaining type declarations are not desugared.
Finn Teegen's avatar
Finn Teegen committed
91
-- Since they cannot occur in local declaration groups, they are filtered
92
93
94
-- out separately. Actually, the transformation is slightly more general than
-- necessary as it allows value declarations at the top-level of a module.

Finn Teegen's avatar
Finn Teegen committed
95
96
97
desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module PredType
        -> (Module PredType, ValueEnv)
desugar xs vEnv tcEnv (Module ps m es is ds)
98
99
  = (Module ps m es is ds', valueEnv s')
  where (ds', s') = S.runState (desugarModuleDecls ds)
Finn Teegen's avatar
Finn Teegen committed
100
                               (DesugarState m xs tcEnv vEnv 1)
101
102
103
104
105
106
107
108
109

-- ---------------------------------------------------------------------------
-- Desugaring monad and accessor functions
-- ---------------------------------------------------------------------------

-- New identifiers may be introduced while desugaring pattern declarations,
-- case and lambda-expressions, list comprehensions, and record selections
-- and updates. As usual, we use a state monad transformer for generating
-- unique names. In addition, the state is also used for passing through the
110
111
112
113
114
115
116
-- type environment, which must be augmented with the types of these new
-- variables.

data DesugarState = DesugarState
  { moduleIdent :: ModuleIdent      -- read-only
  , extensions  :: [KnownExtension] -- read-only
  , tyConsEnv   :: TCEnv            -- read-only
117
118
  , valueEnv    :: ValueEnv         -- will be extended
  , nextId      :: Integer          -- counter
119
120
121
122
123
124
125
  }

type DsM a = S.State DesugarState a

getModuleIdent :: DsM ModuleIdent
getModuleIdent = S.gets moduleIdent

126
127
checkNegativeLitsExtension :: DsM Bool
checkNegativeLitsExtension = S.gets (\s -> NegativeLiterals `elem` extensions s)
128
129
130
131
132
133
134
135
136
137

getTyConsEnv :: DsM TCEnv
getTyConsEnv = S.gets tyConsEnv

getValueEnv :: DsM ValueEnv
getValueEnv = S.gets valueEnv

getNextId :: DsM Integer
getNextId = do
  nid <- S.gets nextId
Finn Teegen's avatar
Finn Teegen committed
138
  S.modify $ \s -> s { nextId = succ nid }
139
140
141
142
143
144
  return nid

-- ---------------------------------------------------------------------------
-- Generation of fresh names
-- ---------------------------------------------------------------------------

145
-- Create a fresh variable ident for a given prefix with a monomorphic type
Finn Teegen's avatar
Finn Teegen committed
146
147
148
149
freshVar :: Typeable t => String -> t -> DsM (PredType, Ident)
freshVar prefix t = do
  v <- (mkIdent . (prefix ++) . show) <$> getNextId
  return (predType $ typeOf t, v)
150

151
152
153
-- ---------------------------------------------------------------------------
-- Desugaring
-- ---------------------------------------------------------------------------
154

Finn Teegen's avatar
Finn Teegen committed
155
desugarModuleDecls :: [Decl PredType] -> DsM [Decl PredType]
156
desugarModuleDecls ds = do
157
  ds'   <- concatMapM dsRecordDecl ds
Finn Teegen's avatar
Finn Teegen committed
158
159
  ds''  <- mapM dsClassAndInstanceDecl ds'
  ds''' <- dsDeclGroup ds''
160
  return $ filter (not . liftM2 (||) isValueDecl isTypeSig) ds'' ++ ds'''
Finn Teegen's avatar
Finn Teegen committed
161
162
163
164
165
166
167
168
169
170
171
172

-- -----------------------------------------------------------------------------
-- Desugaring of class and instance declarations
-- -----------------------------------------------------------------------------

dsClassAndInstanceDecl :: Decl PredType -> DsM (Decl PredType)
dsClassAndInstanceDecl (ClassDecl p cx cls tv ds) =
  ClassDecl p cx cls tv . (tds ++) <$> dsDeclGroup vds
  where (tds, vds) = partition isTypeSig ds
dsClassAndInstanceDecl (InstanceDecl p cx cls ty ds) =
  InstanceDecl p cx cls ty <$> dsDeclGroup ds
dsClassAndInstanceDecl d = return d
173

174
175
176
177
178
179
180
181
182
-- -----------------------------------------------------------------------------
-- Desugaring of type declarations: records
-- -----------------------------------------------------------------------------

-- As an extension to the Curry language, the compiler supports Haskell's
-- record syntax, which introduces field labels for data and renaming types.
-- Field labels can be used in constructor declarations, patterns,
-- and expressions. For further convenience, an implicit selector
-- function is introduced for each field label.
183

184
185
-- Generate selector functions for record labels and replace record
-- constructor declarations by ordinary constructor declarations.
Finn Teegen's avatar
Finn Teegen committed
186
dsRecordDecl :: Decl PredType -> DsM [Decl PredType]
Finn Teegen's avatar
Finn Teegen committed
187
dsRecordDecl (DataDecl p tc tvs cs clss) = do
188
189
190
  m <- getModuleIdent
  let qcs = map (qualifyWith m . constrId) cs
  selFuns <- mapM (genSelFun p qcs) (nub $ concatMap recordLabels cs)
Finn Teegen's avatar
Finn Teegen committed
191
192
  return $ DataDecl p tc tvs (map unlabelConstr cs) clss : selFuns
dsRecordDecl (NewtypeDecl p tc tvs nc clss) = do
193
194
195
  m <- getModuleIdent
  let qc = qualifyWith m (nconstrId nc)
  selFun <- mapM (genSelFun p [qc]) (nrecordLabels nc)
Finn Teegen's avatar
Finn Teegen committed
196
  return $ NewtypeDecl p tc tvs (unlabelNewConstr nc) clss : selFun
Finn Teegen's avatar
Finn Teegen committed
197
dsRecordDecl d = return [d]
198
199

-- Generate a selector function for a single record label
Finn Teegen's avatar
Finn Teegen committed
200
201
202
203
204
205
genSelFun :: Position -> [QualIdent] -> Ident -> DsM (Decl PredType)
genSelFun p qcs l = do
  m <- getModuleIdent
  vEnv <- getValueEnv
  let ForAll _ pty = varType (qualifyWith m l) vEnv
  FunctionDecl p pty l <$> concatMapM (genSelEqn p l) qcs
206
207
208

-- Generate a selector equation for a label and a constructor if the label
-- is applicable, otherwise the empty list is returned.
Finn Teegen's avatar
Finn Teegen committed
209
genSelEqn :: Position -> Ident -> QualIdent -> DsM [Equation PredType]
210
genSelEqn p l qc = do
Finn Teegen's avatar
Finn Teegen committed
211
212
213
  vEnv <- getValueEnv
  let (ls, ty) = conType qc vEnv
      (tys, ty0) = arrowUnapply (instType ty)
214
  case elemIndex l ls of
Finn Teegen's avatar
Finn Teegen committed
215
216
217
218
    Just n  -> do
      vs <- mapM (freshVar "_#rec") tys
      let pat = constrPattern (predType ty0) qc vs
      return [mkEquation p l [pat] (uncurry mkVar (vs !! n))]
219
220
221
222
    Nothing -> return []

-- Remove any labels from a data constructor declaration
unlabelConstr :: ConstrDecl -> ConstrDecl
Finn Teegen's avatar
Finn Teegen committed
223
unlabelConstr (RecordDecl p evs cx c fs) = ConstrDecl p evs cx c tys
224
  where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]
Finn Teegen's avatar
Finn Teegen committed
225
unlabelConstr c                          = c
226
227
228

-- Remove any labels from a newtype constructor declaration
unlabelNewConstr :: NewConstrDecl -> NewConstrDecl
Finn Teegen's avatar
Finn Teegen committed
229
230
unlabelNewConstr (NewRecordDecl p nc (_, ty)) = NewConstrDecl p nc ty
unlabelNewConstr c                            = c
231
232
233
234
235
236
237
238
239

-- -----------------------------------------------------------------------------
-- Desugaring of value declarations
-- -----------------------------------------------------------------------------

-- Within a declaration group, all type signatures are discarded. First,
-- the patterns occurring in the left hand sides of pattern declarations
-- and external declarations are desugared. Due to lazy patterns, the former
-- may add further declarations to the group that must be desugared as well.
Finn Teegen's avatar
Finn Teegen committed
240
dsDeclGroup :: [Decl PredType] -> DsM [Decl PredType]
241
dsDeclGroup ds = concatMapM dsDeclLhs (filter isValueDecl ds) >>= mapM dsDeclRhs
242

Finn Teegen's avatar
Finn Teegen committed
243
dsDeclLhs :: Decl PredType -> DsM [Decl PredType]
244
dsDeclLhs (PatternDecl p t rhs) = do
245
  (ds', t') <- dsPat p [] t
246
247
248
249
  dss'      <- mapM dsDeclLhs ds'
  return $ PatternDecl p t' rhs : concat dss'
dsDeclLhs d                     = return [d]

250
-- TODO: Check if obsolete and remove
251
252
253
254
255
256
257
258
259
-- After desugaring its right hand side, each equation is eta-expanded
-- by adding as many variables as necessary to the argument list and
-- applying the right hand side to those variables (Note: eta-expansion
-- is disabled in the version for PAKCS).
-- Furthermore every occurrence of a record type within the type of a function
-- is simplified to the corresponding type constructor from the record
-- declaration. This is possible because currently records must not be empty
-- and a record label belongs to only one record declaration.

260
-- Desugaring of the right-hand-side of declarations
Finn Teegen's avatar
Finn Teegen committed
261
dsDeclRhs :: Decl PredType -> DsM (Decl PredType)
Finn Teegen's avatar
Finn Teegen committed
262
dsDeclRhs (FunctionDecl p pty f eqs) =
Finn Teegen's avatar
Finn Teegen committed
263
  FunctionDecl p pty f <$> mapM dsEquation eqs
Finn Teegen's avatar
Finn Teegen committed
264
265
266
267
dsDeclRhs (PatternDecl      p t rhs) = PatternDecl p t <$> dsRhs p id rhs
dsDeclRhs d@(FreeDecl           _ _) = return d
dsDeclRhs d@(ExternalDecl       _ _) = return d
dsDeclRhs _                          =
Finn Teegen's avatar
Finn Teegen committed
268
  error "Desugar.dsDeclRhs: no pattern match"
269

270
-- Desugaring of an equation
Finn Teegen's avatar
Finn Teegen committed
271
dsEquation :: Equation PredType -> DsM (Equation PredType)
272
dsEquation (Equation p lhs rhs) = do
273
274
275
276
277
278
  (     cs1, ts1) <- dsNonLinearity         ts
  (ds1, cs2, ts2) <- dsFunctionalPatterns p ts1
  (ds2,      ts3) <- mapAccumM (dsPat p) [] ts2
  rhs'            <- dsRhs p (constrain cs2 . constrain cs1)
                             (addDecls (ds1 ++ ds2) rhs)
  return $ Equation p (FunLhs f ts3) rhs'
279
280
  where (f, ts) = flatLhs lhs

281
282
283
-- Constrain an expression by a list of constraints.
-- @constrain []  e  ==  e@
-- @constrain c_n e  ==  (c_1 & ... & c_n) &> e@
Finn Teegen's avatar
Finn Teegen committed
284
constrain :: [Expression PredType] -> Expression PredType -> Expression PredType
285
constrain cs e = if null cs then e else foldr1 (&) cs &> e
286
287
288
289
290
291
292
293
294
295
296
297
298

-- -----------------------------------------------------------------------------
-- Desugaring of right-hand sides
-- -----------------------------------------------------------------------------

-- A list of boolean guards is expanded into a nested if-then-else
-- expression, whereas a constraint guard is replaced by a case
-- expression. Note that if the guard type is 'Success' only a
-- single guard is allowed for each equation (This change was
-- introduced in version 0.8 of the Curry report.). We check for the
-- type 'Bool' of the guard because the guard's type defaults to
-- 'Success' if it is not restricted by the guard expression.

Finn Teegen's avatar
Finn Teegen committed
299
300
dsRhs :: Position -> (Expression PredType -> Expression PredType)
      -> Rhs PredType -> DsM (Rhs PredType)
301
dsRhs p f rhs =     expandRhs (prelFailed (typeOf rhs)) f rhs
302
303
304
305
                >>= dsExpr pRhs
                >>= return . simpleRhs pRhs
  where
  pRhs = fromMaybe p (getRhsPosition rhs)
306

Finn Teegen's avatar
Finn Teegen committed
307
308
expandRhs :: Expression PredType -> (Expression PredType -> Expression PredType)
          -> Rhs PredType -> DsM (Expression PredType)
309
310
311
expandRhs _  f (SimpleRhs _ e ds) = return $ Let ds (f e)
expandRhs e0 f (GuardedRhs es ds) = (Let ds . f) <$> expandGuards e0 es

Finn Teegen's avatar
Finn Teegen committed
312
313
314
315
expandGuards :: Expression PredType -> [CondExpr PredType]
             -> DsM (Expression PredType)
expandGuards e0 es =
  return $ if boolGuards es then foldr mkIfThenElse e0 es else mkCond es
316
  where
Finn Teegen's avatar
Finn Teegen committed
317
  mkIfThenElse (CondExpr _ g e) = IfThenElse g e
318
  mkCond [CondExpr _ g e] = g &> e
319
320
  mkCond _                = error "Desugar.expandGuards.mkCond: non-unary list"

Finn Teegen's avatar
Finn Teegen committed
321
322
323
boolGuards :: [CondExpr PredType] -> Bool
boolGuards []                    = False
boolGuards (CondExpr _ g _ : es) = not (null es) || typeOf g == boolType
324
325

-- Add additional declarations to a right-hand side
Finn Teegen's avatar
Finn Teegen committed
326
addDecls :: [Decl PredType] -> Rhs PredType -> Rhs PredType
327
328
329
addDecls ds (SimpleRhs p e ds') = SimpleRhs p e (ds ++ ds')
addDecls ds (GuardedRhs es ds') = GuardedRhs es (ds ++ ds')

330
getRhsPosition :: Rhs a -> Maybe Position
331
getRhsPosition (SimpleRhs p _ _) = Just p
332
getRhsPosition (GuardedRhs  _ _) = Nothing
333

334
335
336
337
-- -----------------------------------------------------------------------------
-- Desugaring of non-linear patterns
-- -----------------------------------------------------------------------------

338
339
340
341
-- The desugaring traverses a pattern in depth-first order and collects
-- all variables. If it encounters a variable which has been previously
-- introduced, the second occurrence is changed to a fresh variable
-- and a new pair (newvar, oldvar) is saved to generate constraints later.
342
-- Non-linear patterns inside single functional patterns are not desugared,
343
-- as this special case is handled later.
Finn Teegen's avatar
Finn Teegen committed
344
345
dsNonLinearity :: [Pattern PredType]
               -> DsM ([Expression PredType], [Pattern PredType])
346
347
348
349
dsNonLinearity ts = do
  ((_, cs), ts') <- mapAccumM dsNonLinear (Set.empty, []) ts
  return (reverse cs, ts')

Finn Teegen's avatar
Finn Teegen committed
350
type NonLinearEnv = (Set.Set Ident, [Expression PredType])
351

Finn Teegen's avatar
Finn Teegen committed
352
353
354
dsNonLinear :: NonLinearEnv -> Pattern PredType
            -> DsM (NonLinearEnv, Pattern PredType)
dsNonLinear env l@(LiteralPattern        _ _) = return (env, l)
Finn Teegen's avatar
Finn Teegen committed
355
dsNonLinear env n@(NegativePattern       _ _) = return (env, n)
Finn Teegen's avatar
Finn Teegen committed
356
dsNonLinear env t@(VariablePattern       _ v)
357
  | isAnonId v         = return (env, t)
358
  | v `Set.member` vis = do
Finn Teegen's avatar
Finn Teegen committed
359
360
    v' <- freshVar "_#nonlinear" t
    return ((vis, mkStrictEquality v v' : eqs), uncurry VariablePattern v')
361
362
  | otherwise          = return ((Set.insert v vis, eqs), t)
  where (vis, eqs) = env
Finn Teegen's avatar
Finn Teegen committed
363
364
365
dsNonLinear env (ConstructorPattern pty c ts) = second (ConstructorPattern pty c)
                                                <$> mapAccumM dsNonLinear env ts
dsNonLinear env (InfixPattern   pty t1 op t2) = do
366
367
  (env1, t1') <- dsNonLinear env  t1
  (env2, t2') <- dsNonLinear env1 t2
Finn Teegen's avatar
Finn Teegen committed
368
  return (env2, InfixPattern pty t1' op t2')
369
370
dsNonLinear env (ParenPattern            t) = second ParenPattern
                                              <$> dsNonLinear env t
Finn Teegen's avatar
Finn Teegen committed
371
372
dsNonLinear env (RecordPattern      pty c fs) =
  second (RecordPattern pty c) <$> mapAccumM (dsField dsNonLinear) env fs
Finn Teegen's avatar
Finn Teegen committed
373
dsNonLinear env (TuplePattern             ts) = second TuplePattern
Finn Teegen's avatar
Finn Teegen committed
374
                                                <$> mapAccumM dsNonLinear env ts
Finn Teegen's avatar
Finn Teegen committed
375
dsNonLinear env (ListPattern          pty ts) = second (ListPattern pty)
Finn Teegen's avatar
Finn Teegen committed
376
                                                <$> mapAccumM dsNonLinear env ts
Finn Teegen's avatar
Finn Teegen committed
377
dsNonLinear env (AsPattern               v t) = do
Finn Teegen's avatar
Finn Teegen committed
378
379
380
  let pty = predType $ typeOf t
  (env1, VariablePattern _ v') <- dsNonLinear env (VariablePattern pty v)
  (env2, t') <- dsNonLinear env1 t
381
  return (env2, AsPattern v' t')
Finn Teegen's avatar
Finn Teegen committed
382
dsNonLinear env (LazyPattern               t) = second LazyPattern
Finn Teegen's avatar
Finn Teegen committed
383
384
385
                                                <$> dsNonLinear env t
dsNonLinear env fp@(FunctionPattern    _ _ _) = dsNonLinearFuncPat env fp
dsNonLinear env fp@(InfixFuncPattern _ _ _ _) = dsNonLinearFuncPat env fp
386

Finn Teegen's avatar
Finn Teegen committed
387
388
dsNonLinearFuncPat :: NonLinearEnv -> Pattern PredType
                   -> DsM (NonLinearEnv, Pattern PredType)
389
dsNonLinearFuncPat (vis, eqs) fp = do
Finn Teegen's avatar
Finn Teegen committed
390
391
392
393
394
395
396
397
398
399
400
401
  let fpVars = map (\(v, _, pty) -> (pty, v)) $ patternVars fp
      vs     = filter ((`Set.member` vis) . snd) fpVars
  vs' <- mapM (freshVar "_#nonlinear" . uncurry VariablePattern) vs
  let vis' = foldr (Set.insert . snd) vis fpVars
      fp'  = substPat (zip (map snd vs) (map snd vs')) fp
  return ((vis', zipWith mkStrictEquality (map snd vs) vs' ++ eqs), fp')

mkStrictEquality :: Ident -> (PredType, Ident) -> Expression PredType
mkStrictEquality x (pty, y) = mkVar pty x =:= mkVar pty y

substPat :: [(Ident, Ident)] -> Pattern a -> Pattern a
substPat _ l@(LiteralPattern        _ _) = l
Finn Teegen's avatar
Finn Teegen committed
402
substPat _ n@(NegativePattern       _ _) = n
Finn Teegen's avatar
Finn Teegen committed
403
404
405
406
407
408
409
410
substPat s (VariablePattern         a v) = VariablePattern a
                                         $ fromMaybe v (lookup v s)
substPat s (ConstructorPattern   a c ps) = ConstructorPattern a c
                                         $ map (substPat s) ps
substPat s (InfixPattern     a p1 op p2) = InfixPattern a (substPat s p1) op
                                                        (substPat s p2)
substPat s (ParenPattern              p) = ParenPattern (substPat s p)
substPat s (RecordPattern        a c fs) = RecordPattern a c (map substField fs)
411
  where substField (Field pos l pat) = Field pos l (substPat s pat)
Finn Teegen's avatar
Finn Teegen committed
412
substPat s (TuplePattern             ps) = TuplePattern
Finn Teegen's avatar
Finn Teegen committed
413
                                         $ map (substPat s) ps
Finn Teegen's avatar
Finn Teegen committed
414
substPat s (ListPattern            a ps) = ListPattern a
Finn Teegen's avatar
Finn Teegen committed
415
416
417
                                         $ map (substPat s) ps
substPat s (AsPattern               v p) = AsPattern (fromMaybe v (lookup v s))
                                                     (substPat s p)
Finn Teegen's avatar
Finn Teegen committed
418
substPat s (LazyPattern               p) = LazyPattern (substPat s p)
Finn Teegen's avatar
Finn Teegen committed
419
420
421
422
substPat s (FunctionPattern      a f ps) = FunctionPattern a f
                                         $ map (substPat s) ps
substPat s (InfixFuncPattern a p1 op p2) = InfixFuncPattern a (substPat s p1) op
                                                            (substPat s p2)
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441

-- -----------------------------------------------------------------------------
-- Desugaring of functional patterns
-- -----------------------------------------------------------------------------

-- Desugaring of functional patterns works in the following way:
--  1. The patterns are recursively traversed from left to right
--     to extract every functional pattern (note that functional patterns
--     can not be nested).
--     Each pattern is replaced by a fresh variable and a pair
--     (variable, functional pattern) is generated.
--  2. The variable-pattern pairs of the form @(v, p)@ are collected and
--     transformed into additional constraints of the form @p =:<= v@,
--     where the pattern @p@ is converted to the corresponding expression.
--     In addition, any variable occurring in @p@ is declared as a fresh
--     free variable.
--     Multiple constraints will later be combined using the @&>@-operator
--     such that the patterns are evaluated from left to right.

Finn Teegen's avatar
Finn Teegen committed
442
443
444
dsFunctionalPatterns
  :: Position -> [Pattern PredType]
  -> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])
445
446
447
448
dsFunctionalPatterns p ts = do
  -- extract functional patterns
  (bs, ts') <- mapAccumM elimFP [] ts
  -- generate declarations of free variables and constraints
Finn Teegen's avatar
Finn Teegen committed
449
  let (ds, cs) = genFPExpr p (concatMap patternVars ts') (reverse bs)
450
451
452
  -- return (declarations, constraints, desugared patterns)
  return (ds, cs, ts')

Finn Teegen's avatar
Finn Teegen committed
453
type LazyBinding = (Pattern PredType, (PredType, Ident))
454

Finn Teegen's avatar
Finn Teegen committed
455
456
457
elimFP :: [LazyBinding] -> Pattern PredType
       -> DsM ([LazyBinding], Pattern PredType)
elimFP bs p@(LiteralPattern        _ _) = return (bs, p)
Finn Teegen's avatar
Finn Teegen committed
458
elimFP bs p@(NegativePattern       _ _) = return (bs, p)
Finn Teegen's avatar
Finn Teegen committed
459
460
461
462
elimFP bs p@(VariablePattern       _ _) = return (bs, p)
elimFP bs (ConstructorPattern pty c ts) = second (ConstructorPattern pty c)
                                          <$> mapAccumM elimFP bs ts
elimFP bs (InfixPattern   pty t1 op t2) = do
463
464
  (bs1, t1') <- elimFP bs  t1
  (bs2, t2') <- elimFP bs1 t2
Finn Teegen's avatar
Finn Teegen committed
465
466
467
468
  return (bs2, InfixPattern pty t1' op t2')
elimFP bs (ParenPattern              t) = second ParenPattern <$> elimFP bs t
elimFP bs (RecordPattern      pty c fs) = second (RecordPattern pty c)
                                          <$> mapAccumM (dsField elimFP) bs fs
Finn Teegen's avatar
Finn Teegen committed
469
elimFP bs (TuplePattern             ts) = second TuplePattern
Finn Teegen's avatar
Finn Teegen committed
470
                                          <$> mapAccumM elimFP bs ts
Finn Teegen's avatar
Finn Teegen committed
471
elimFP bs (ListPattern          pty ts) = second (ListPattern pty)
Finn Teegen's avatar
Finn Teegen committed
472
473
                                          <$> mapAccumM elimFP bs ts
elimFP bs (AsPattern               v t) = second (AsPattern   v) <$> elimFP bs t
Finn Teegen's avatar
Finn Teegen committed
474
elimFP bs (LazyPattern               t) = second LazyPattern <$> elimFP bs t
Finn Teegen's avatar
Finn Teegen committed
475
476
477
478
479
480
481
482
483
elimFP bs p@(FunctionPattern     _ _ _) = do
 (pty, v) <- freshVar "_#funpatt" p
 return ((p, (pty, v)) : bs, VariablePattern pty v)
elimFP bs p@(InfixFuncPattern  _ _ _ _) = do
 (pty, v) <- freshVar "_#funpatt" p
 return ((p, (pty, v)) : bs, VariablePattern pty v)

genFPExpr :: Position -> [(Ident, Int, PredType)] -> [LazyBinding]
          -> ([Decl PredType], [Expression PredType])
484
485
486
genFPExpr p vs bs
  | null bs   = ([]               , [])
  | null free = ([]               , cs)
Finn Teegen's avatar
Finn Teegen committed
487
  | otherwise = ([FreeDecl p (map (\(v, _, pty) -> Var pty v) free)], cs)
488
  where
Finn Teegen's avatar
Finn Teegen committed
489
490
491
492
493
494
495
496
  mkLB (t, (pty, v)) = let (t', es) = fp2Expr t
                       in  (t' =:<= mkVar pty v) : es
  cs   = concatMap mkLB bs
  free = nub $ filter (not . isAnonId . fst3) $
                 concatMap patternVars (map fst bs) \\ vs

fp2Expr :: Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr (LiteralPattern          pty l) = (Literal pty l, [])
Finn Teegen's avatar
Finn Teegen committed
497
fp2Expr (NegativePattern         pty l) = (Literal pty (negateLiteral l), [])
Finn Teegen's avatar
Finn Teegen committed
498
499
fp2Expr (VariablePattern         pty v) = (mkVar pty v, [])
fp2Expr (ConstructorPattern   pty c ts) =
500
  let (ts', ess) = unzip $ map fp2Expr ts
501
502
      pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf ts
  in  (apply (Constructor pty' c) ts', concat ess)
Finn Teegen's avatar
Finn Teegen committed
503
fp2Expr (InfixPattern   pty t1 op t2) =
504
505
  let (t1', es1) = fp2Expr t1
      (t2', es2) = fp2Expr t2
506
      pty' = predType $ foldr TypeArrow (unpredType pty) [typeOf t1, typeOf t2]
Finn Teegen's avatar
Finn Teegen committed
507
508
  in  (InfixApply t1' (InfixConstr pty' op) t2', es1 ++ es2)
fp2Expr (ParenPattern                t) = first Paren (fp2Expr t)
Finn Teegen's avatar
Finn Teegen committed
509
fp2Expr (TuplePattern               ts) =
510
  let (ts', ess) = unzip $ map fp2Expr ts
Finn Teegen's avatar
Finn Teegen committed
511
512
  in  (Tuple ts', concat ess)
fp2Expr (ListPattern            pty ts) =
513
  let (ts', ess) = unzip $ map fp2Expr ts
Finn Teegen's avatar
Finn Teegen committed
514
  in  (List pty ts', concat ess)
Finn Teegen's avatar
Finn Teegen committed
515
fp2Expr (FunctionPattern      pty f ts) =
516
  let (ts', ess) = unzip $ map fp2Expr ts
517
518
      pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf ts
  in  (apply (Variable pty' f) ts', concat ess)
Finn Teegen's avatar
Finn Teegen committed
519
fp2Expr (InfixFuncPattern pty t1 op t2) =
520
521
  let (t1', es1) = fp2Expr t1
      (t2', es2) = fp2Expr t2
522
      pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf [t1, t2]
Finn Teegen's avatar
Finn Teegen committed
523
524
  in  (InfixApply t1' (InfixOp pty' op) t2', es1 ++ es2)
fp2Expr (AsPattern                 v t) =
525
  let (t', es) = fp2Expr t
Finn Teegen's avatar
Finn Teegen committed
526
527
528
      pty = predType $ typeOf t
  in  (mkVar pty v, (t' =:<= mkVar pty v) : es)
fp2Expr (RecordPattern        pty c fs) =
529
530
  let (fs', ess) = unzip [ (Field p f e, es) | Field p f t <- fs
                                             , let (e, es) = fp2Expr t]
Finn Teegen's avatar
Finn Teegen committed
531
532
  in  (Record pty c fs', concat ess)
fp2Expr t                               = internalError $
533
534
535
  "Desugar.fp2Expr: Unexpected constructor term: " ++ show t

-- -----------------------------------------------------------------------------
536
-- Desugaring of ordinary patterns
537
-- -----------------------------------------------------------------------------
538
539
540
541
542
543
544
545

-- The transformation of patterns is straight forward except for lazy
-- patterns. A lazy pattern '~t' is replaced by a fresh
-- variable 'v' and a new local declaration 't = v' in the
-- scope of the pattern. In addition, as-patterns 'v@t' where
-- 't' is a variable or an as-pattern are replaced by 't' in combination
-- with a local declaration for 'v'.

546
547
548
549
550
551
552
553
554
555
556
557
558
-- Record patterns are transformed into normal constructor patterns by
-- rearranging fields in the order of the record's declaration, adding
-- fresh variables in place of omitted fields, and discarding the field
-- labels.

-- Note: By rearranging fields here we loose the ability to comply
-- strictly with the Haskell 98 pattern matching semantics, which matches
-- fields of a record pattern in the order of their occurrence in the
-- pattern. However, keep in mind that Haskell matches alternatives from
-- top to bottom and arguments within an equation or alternative from
-- left to right, which is not the case in Curry except for rigid case
-- expressions.

Finn Teegen's avatar
Finn Teegen committed
559
560
dsLiteralPat :: PredType -> Literal
             -> Either (Pattern PredType) (Pattern PredType)
Finn Teegen's avatar
Finn Teegen committed
561
562
dsLiteralPat pty c@(Char _) = Right (LiteralPattern pty c)
dsLiteralPat pty (Int i) =
Finn Teegen's avatar
Finn Teegen committed
563
564
565
  Right (LiteralPattern pty (fixLiteral (unpredType pty)))
  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
        fixLiteral ty
Finn Teegen's avatar
Finn Teegen committed
566
567
568
569
570
          | ty == floatType = Float $ fromInteger i
          | otherwise = Int i
dsLiteralPat pty f@(Float _) = Right (LiteralPattern pty f)
dsLiteralPat pty (String cs) =
  Left $ ListPattern pty $ map (LiteralPattern pty' . Char) cs
Finn Teegen's avatar
Finn Teegen committed
571
572
573
574
575
576
577
  where pty' = predType $ elemType $ unpredType pty

dsPat :: Position -> [Decl PredType] -> Pattern PredType
      -> DsM ([Decl PredType], Pattern PredType)
dsPat _ ds v@(VariablePattern     _ _) = return (ds, v)
dsPat p ds (LiteralPattern      pty l) =
  either (dsPat p ds) (return . (,) ds) (dsLiteralPat pty l)
Finn Teegen's avatar
Finn Teegen committed
578
dsPat p ds (NegativePattern     pty l) =
Finn Teegen's avatar
Finn Teegen committed
579
580
581
582
583
  dsPat p ds (LiteralPattern pty (negateLiteral l))
dsPat p ds (ConstructorPattern pty c ts) =
  second (ConstructorPattern pty c) <$> mapAccumM (dsPat p) ds ts
dsPat p ds (InfixPattern  pty t1 op t2) =
  dsPat p ds (ConstructorPattern pty op [t1, t2])
584
dsPat p ds (ParenPattern           t) = dsPat p ds t
Finn Teegen's avatar
Finn Teegen committed
585
586
587
588
589
590
591
592
593
dsPat p ds (RecordPattern   pty c fs) = do
  vEnv <- getValueEnv
  --TODO: Rework
  let (ls, tys) = argumentTypes (unpredType pty) c vEnv
      tsMap = map field2Tuple fs
      anonTs = map (flip VariablePattern anonId . predType) tys
      maybeTs = map (flip lookup tsMap) ls
      ts = zipWith fromMaybe anonTs maybeTs
  dsPat p ds (ConstructorPattern pty c ts)
Finn Teegen's avatar
Finn Teegen committed
594
595
dsPat p ds (TuplePattern          ts) =
  dsPat p ds (ConstructorPattern pty (qTupleId $ length ts) ts)
Finn Teegen's avatar
Finn Teegen committed
596
  where pty = predType (tupleType (map typeOf ts))
Finn Teegen's avatar
Finn Teegen committed
597
598
599
600
dsPat p ds (ListPattern       pty ts) =
  second (dsList cons nil) <$> mapAccumM (dsPat p) ds ts
  where nil = ConstructorPattern pty qNilId []
        cons t ts' = ConstructorPattern pty qConsId [t, ts']
601
dsPat p ds (AsPattern            v t) = dsAs p v <$> dsPat p ds t
Finn Teegen's avatar
Finn Teegen committed
602
dsPat p ds (LazyPattern            t) = dsLazy p ds t
Finn Teegen's avatar
Finn Teegen committed
603
dsPat p ds (FunctionPattern    pty f ts) = second (FunctionPattern pty f)
604
                                        <$> mapAccumM (dsPat p) ds ts
Finn Teegen's avatar
Finn Teegen committed
605
606
dsPat p ds (InfixFuncPattern pty t1 f t2) =
  dsPat p ds (FunctionPattern pty f [t1, t2])
607

Finn Teegen's avatar
Finn Teegen committed
608
609
dsAs :: Position -> Ident -> ([Decl PredType], Pattern PredType)
     -> ([Decl PredType], Pattern PredType)
610
dsAs p v (ds, t) = case t of
Finn Teegen's avatar
Finn Teegen committed
611
612
613
614
  VariablePattern pty v' -> (varDecl p pty v (mkVar pty v') : ds, t)
  AsPattern        v' t' -> (varDecl p pty' v (mkVar pty' v') : ds, t)
    where pty' = predType $ typeOf t'
  _                      -> (ds, AsPattern v t)
615

Finn Teegen's avatar
Finn Teegen committed
616
dsLazy :: Position -> [Decl PredType] -> Pattern PredType
Finn Teegen's avatar
Finn Teegen committed
617
       -> DsM ([Decl PredType], Pattern PredType)
Finn Teegen's avatar
Finn Teegen committed
618
dsLazy p ds t = case t of
Finn Teegen's avatar
Finn Teegen committed
619
  VariablePattern _ _ -> return (ds, t)
Finn Teegen's avatar
Finn Teegen committed
620
621
622
623
624
625
  ParenPattern   t' -> dsLazy p ds t'
  AsPattern    v t' -> dsAs p v <$> dsLazy p ds t'
  LazyPattern    t' -> dsLazy p ds t'
  _                 -> do
    (pty, v') <- freshVar "_#lazy" t
    return (patDecl p t (mkVar pty v') : ds, VariablePattern pty v')
626

Finn Teegen's avatar
Finn Teegen committed
627
{-
628
629
630
-- -----------------------------------------------------------------------------
-- Desugaring of expressions
-- -----------------------------------------------------------------------------
631

632
633
-- Record construction expressions are transformed into normal
-- constructor applications by rearranging fields in the order of the
634
-- record's declaration, passing `Prelude.unknown` in place of
635
636
637
638
639
640
-- omitted fields, and discarding the field labels. The transformation of
-- record update expressions is a bit more involved as we must match the
-- updated expression with all valid constructors of the expression's
-- type. As stipulated by the Haskell 98 Report, a record update
-- expression @e { l_1 = e_1, ..., l_k = e_k }@ succeeds only if @e@ reduces to
-- a value @C e'_1 ... e'_n@ such that @C@'s declaration contains all
641
642
-- field labels @l_1,...,l_k@. In contrast to Haskell, we do not report
-- an error if this is not the case, but call failed instead.
Finn Teegen's avatar
Finn Teegen committed
643
644
645
646
647
648
-}
dsExpr :: Position -> Expression PredType -> DsM (Expression PredType)
dsExpr p (Literal     pty l) =
  either (dsExpr p) return (dsLiteral pty l)
dsExpr _ var@(Variable pty v)
  | isAnonId (unqualify v)   = return $ prelUnknown $ unpredType pty
649
  | otherwise                = return var
Finn Teegen's avatar
Finn Teegen committed
650
dsExpr _ c@(Constructor _ _) = return c
651
dsExpr p (Paren           e) = dsExpr p e
Finn Teegen's avatar
Finn Teegen committed
652
653
654
655
656
657
658
659
660
661
dsExpr p (Typed       e qty) = Typed <$> dsExpr p e <*> dsQualTypeExpr qty
dsExpr p (Record   pty c fs) = do
  vEnv <- getValueEnv
  --TODO: Rework
  let (ls, tys) = argumentTypes (unpredType pty) c vEnv
      esMap = map field2Tuple fs
      unknownEs = map prelUnknown tys
      maybeEs = map (flip lookup esMap) ls
      es = zipWith fromMaybe unknownEs maybeEs
  dsExpr p (applyConstr pty c tys es)
662
dsExpr p (RecordUpdate e fs) = do
Finn Teegen's avatar
Finn Teegen committed
663
  alts  <- constructors tc >>= concatMapM updateAlt
Finn Teegen's avatar
Finn Teegen committed
664
  dsExpr p $ Case Flex e (map (uncurry (caseAlt p)) alts)
Finn Teegen's avatar
Finn Teegen committed
665
666
  where ty = typeOf e
        pty = predType ty
667
668
669
        tc = rootOfType (arrowBase ty)
        updateAlt (RecordConstr c _ _ ls _)
          | all (`elem` qls2) (map fieldLabel fs)= do
Finn Teegen's avatar
Finn Teegen committed
670
            let qc = qualifyLike tc c
671
672
673
674
            vEnv <- getValueEnv
            let (qls, tys) = argumentTypes ty qc vEnv
            vs <- mapM (freshVar "_#rec") tys
            let pat = constrPattern pty qc vs
Finn Teegen's avatar
Finn Teegen committed
675
676
677
678
679
                esMap = map field2Tuple fs
                originalEs = map (uncurry mkVar) vs
                maybeEs = map (flip lookup esMap) qls
                es = zipWith fromMaybe originalEs maybeEs
            return [(pat, applyConstr pty qc tys es)]
680
          where qls2 = map (qualifyLike tc) ls
Finn Teegen's avatar
Finn Teegen committed
681
        updateAlt _ = return []
Finn Teegen's avatar
Finn Teegen committed
682
dsExpr p (Tuple      es) = apply (Constructor pty $ qTupleId $ length es) <$> mapM (dsExpr p) es
Finn Teegen's avatar
Finn Teegen committed
683
684
  where pty = predType (foldr TypeArrow (tupleType tys) tys)
        tys = map typeOf es
Finn Teegen's avatar
Finn Teegen committed
685
686
687
688
dsExpr p (List   pty es) = dsList cons nil <$> mapM (dsExpr p) es
  where nil = Constructor pty qNilId
        cons = Apply . Apply (Constructor (predType $ consType $ elemType $ unpredType pty) qConsId)
dsExpr p (ListCompr          e qs) = dsListComp p e qs
Finn Teegen's avatar
Finn Teegen committed
689
690
691
dsExpr p (EnumFrom              e) = Apply (prelEnumFrom (typeOf e))
                                     <$> dsExpr p e
dsExpr p (EnumFromThen      e1 e2) = apply (prelEnumFromThen (typeOf e1))
692
                                     <$> mapM (dsExpr p) [e1, e2]
Finn Teegen's avatar
Finn Teegen committed
693
dsExpr p (EnumFromTo        e1 e2) = apply (prelEnumFromTo (typeOf e1))
694
                                     <$> mapM (dsExpr p) [e1, e2]
Finn Teegen's avatar
Finn Teegen committed
695
dsExpr p (EnumFromThenTo e1 e2 e3) = apply (prelEnumFromThenTo (typeOf e1))
696
                                     <$> mapM (dsExpr p) [e1, e2, e3]
Finn Teegen's avatar
Finn Teegen committed
697
dsExpr p (UnaryMinus            e) = do
698
  e' <- dsExpr p e
699
700
  negativeLitsEnabled <- checkNegativeLitsExtension
  return $ case e' of
Finn Teegen's avatar
Finn Teegen committed
701
702
    Literal pty l | negativeLitsEnabled -> Literal pty $ negateLiteral l
    _                                   -> Apply (prelNegate $ typeOf e') e'
703
dsExpr p (Apply e1 e2) = Apply <$> dsExpr p e1 <*> dsExpr p e2
704
705
706
707
708
dsExpr p (InfixApply e1 op e2) = do
  op' <- dsExpr p (infixOp op)
  e1' <- dsExpr p e1
  e2' <- dsExpr p e2
  return $ apply op' [e1', e2']
709
dsExpr p (LeftSection  e op) = Apply <$> dsExpr p (infixOp op) <*> dsExpr p e
710
711
dsExpr p (RightSection op e) = do
  op' <- dsExpr p (infixOp op)
712
  e'  <- dsExpr p e
Finn Teegen's avatar
Finn Teegen committed
713
714
  return $ apply (prelFlip ty1 ty2 ty3) [op', e']
  where TypeArrow ty1 (TypeArrow ty2 ty3) = typeOf (infixOp op)
Finn Teegen's avatar
Finn Teegen committed
715
dsExpr p expr@(Lambda ts e) = do
Finn Teegen's avatar
Finn Teegen committed
716
  (pty, f) <- freshVar "_#lambda" expr
Finn Teegen's avatar
Finn Teegen committed
717
  dsExpr p $ Let [funDecl NoPos pty f ts e] $ mkVar pty f
718
719
dsExpr p (Let ds e) = do
  ds' <- dsDeclGroup ds
720
  e'  <- dsExpr p e
721
  return (if null ds' then e' else Let ds' e')
722
dsExpr p (Do              sts e) = dsDo sts e >>= dsExpr p
Finn Teegen's avatar
Finn Teegen committed
723
dsExpr p (IfThenElse e1 e2 e3) = do
724
725
726
  e1' <- dsExpr p e1
  e2' <- dsExpr p e2
  e3' <- dsExpr p e3
Finn Teegen's avatar
Finn Teegen committed
727
728
  return $ Case Rigid e1' [caseAlt p truePat e2', caseAlt p falsePat e3']
dsExpr p (Case ct e alts) = dsCase p ct e alts
729

Finn Teegen's avatar
Finn Teegen committed
730
731
732
733
734
735
736
737
-- We ignore the context in the type signature of a typed expression, since
-- there should be no possibility to provide an non-empty context without
-- scoped type-variables.
-- TODO: Verify

dsQualTypeExpr :: QualTypeExpr -> DsM QualTypeExpr
dsQualTypeExpr (QualTypeExpr cx ty) = QualTypeExpr cx <$> dsTypeExpr ty

738
739
dsTypeExpr :: TypeExpr -> DsM TypeExpr
dsTypeExpr ty = do
Finn Teegen's avatar
Finn Teegen committed
740
  m <- getModuleIdent
741
  tcEnv <- getTyConsEnv
Finn Teegen's avatar
Finn Teegen committed
742
  return $ fromType (typeVariables ty) (expandType m tcEnv (toType [] ty))
743

744
745
746
-- -----------------------------------------------------------------------------
-- Desugaring of case expressions
-- -----------------------------------------------------------------------------
747

748
749
750
751
752
753
754
755
-- If an alternative in a case expression has boolean guards and all of
-- these guards return 'False', the enclosing case expression does
-- not fail but continues to match the remaining alternatives against the
-- selector expression. In order to implement this semantics, which is
-- compatible with Haskell, we expand an alternative with boolean guards
-- such that it evaluates a case expression with the remaining cases that
-- are compatible with the matched pattern when the guards fail.

Finn Teegen's avatar
Finn Teegen committed
756
757
758
dsCase :: Position -> CaseType -> Expression PredType -> [Alt PredType]
       -> DsM (Expression PredType)
dsCase p ct e alts
Finn Teegen's avatar
Finn Teegen committed
759
  | null alts = internalError "Desugar.dsCase: empty list of alternatives"
760
761
762
  | otherwise = do
    m  <- getModuleIdent
    e' <- dsExpr p e
Finn Teegen's avatar
Finn Teegen committed
763
    v  <- freshVar "_#case" e
764
765
766
767
    alts'  <- mapM dsAltLhs alts
    alts'' <- mapM (expandAlt v ct) (init (tails alts')) >>= mapM dsAltRhs
    return (mkCase m v e' alts'')
  where
Finn Teegen's avatar
Finn Teegen committed
768
  mkCase m (pty, v) e' bs
Finn Teegen's avatar
Finn Teegen committed
769
770
    | v `elem` qfv m bs = Let [varDecl p pty v e'] (Case ct (mkVar pty v) bs)
    | otherwise         = Case ct e' bs
771

Finn Teegen's avatar
Finn Teegen committed
772
dsAltLhs :: Alt PredType -> DsM (Alt PredType)
773
dsAltLhs (Alt p t rhs) = do
774
  (ds', t') <- dsPat p [] t
775
776
  return $ Alt p t' (addDecls ds' rhs)

Finn Teegen's avatar
Finn Teegen committed
777
dsAltRhs :: Alt PredType -> DsM (Alt PredType)
778
dsAltRhs (Alt p t rhs) = Alt p t <$> dsRhs p id rhs
779

Finn Teegen's avatar
Finn Teegen committed
780
781
expandAlt :: (PredType, Ident) -> CaseType -> [Alt PredType]
          -> DsM (Alt PredType)
782
expandAlt _ _  []                   = error "Desugar.expandAlt: empty list"
783
expandAlt v ct (Alt p t rhs : alts) = caseAlt p t <$> expandRhs e0 id rhs
784
  where
Finn Teegen's avatar
Finn Teegen committed
785
  e0 | ct == Flex || null compAlts = prelFailed (typeOf rhs)
Finn Teegen's avatar
Finn Teegen committed
786
     | otherwise = Case ct (uncurry mkVar v) compAlts
Finn Teegen's avatar
Finn Teegen committed
787
  compAlts = filter (isCompatible t . altPattern) alts
788
789
  altPattern (Alt _ t1 _) = t1

Finn Teegen's avatar
Finn Teegen committed
790
791
792
793
794
795
isCompatible :: Pattern a -> Pattern a -> Bool
isCompatible (VariablePattern _ _) _ = True
isCompatible _ (VariablePattern _ _) = True
isCompatible (AsPattern _ t1) t2 = isCompatible t1 t2
isCompatible t1 (AsPattern _ t2) = isCompatible t1 t2
isCompatible (ConstructorPattern _ c1 ts1) (ConstructorPattern _ c2 ts2)
796
  = and ((c1 == c2) : zipWith isCompatible ts1 ts2)
Finn Teegen's avatar
Finn Teegen committed
797
798
isCompatible (LiteralPattern _ l1) (LiteralPattern _ l2) = l1 == l2
isCompatible _ _ = False
799

800
-- -----------------------------------------------------------------------------
801
-- Desugaring of do-Notation
802
-- -----------------------------------------------------------------------------
803

804
805
806
807
-- The do-notation is desugared in the following way:
--
-- `dsDo([]         , e)` -> `e`
-- `dsDo(e'     ; ss, e)` -> `e' >>        dsDo(ss, e)`
808
809
810
-- `dsDo(p <- e'; ss, e)` -> `e' >>= \v -> case v of
--                                           p -> dsDo(ss, e)
--                                           _ -> fail "..."`
811
-- `dsDo(let ds ; ss, e)` -> `let ds in    dsDo(ss, e)`
812
813
dsDo :: [Statement PredType] -> Expression PredType -> DsM (Expression PredType)
dsDo sts e = foldrM dsStmt e sts
Finn Teegen's avatar
Finn Teegen committed
814

815
dsStmt :: Statement PredType -> Expression PredType -> DsM (Expression PredType)
Finn Teegen's avatar
Finn Teegen committed
816
817
818
dsStmt (StmtExpr   e1) e' =
  return $ apply (prelBind_ (typeOf e1) (typeOf e')) [e1, e']
dsStmt (StmtBind t e1) e' = do
819
  v <- freshVar "_#var" t
Finn Teegen's avatar
Finn Teegen committed
820
821
  let func = Lambda [uncurry VariablePattern v] $
               Case Rigid (uncurry mkVar v)
822
823
824
825
                 [ caseAlt NoPos t e'
                 , caseAlt NoPos (uncurry VariablePattern v)
                     (failedPatternMatch $ typeOf e')
                 ]
Finn Teegen's avatar
Finn Teegen committed
826
827
  return $ apply (prelBind (typeOf e1) (typeOf t) (typeOf e')) [e1, func]
  where failedPatternMatch ty =
828
          apply (prelFail ty)
Finn Teegen's avatar
Finn Teegen committed
829
830
            [Literal predStringType $ String "Pattern match failed!"]
dsStmt (StmtDecl   ds) e' = return $ Let ds e'
831

832
-- -----------------------------------------------------------------------------
833
-- Desugaring of List Comprehensions
834
835
-- -----------------------------------------------------------------------------

836
837
838
839
840
841
842
843
844
845
846
847
848
849
-- In general, a list comprehension of the form
-- '[e | t <- l, qs]'
-- is transformed into an expression 'foldr f [] l' where 'f'
-- is a new function defined as
--
--     f x xs =
--       case x of
--           t -> [e | qs] ++ xs
--           _ -> xs
--
-- Note that this translation evaluates the elements of 'l' rigidly,
-- whereas the translation given in the Curry report is flexible.
-- However, it does not seem very useful to have the comprehension
-- generate instances of 't' which do not contribute to the list.
850
-- TODO: Unfortunately, this is incorrect.
851
852
853
854
855
856
857
858
859
860
861

-- Actually, we generate slightly better code in a few special cases.
-- When 't' is a plain variable, the 'case' expression degenerates
-- into a let-binding and the auxiliary function thus becomes an alias
-- for '(++)'. Instead of 'foldr (++)' we use the
-- equivalent prelude function 'concatMap'. In addition, if the
-- remaining list comprehension in the body of the auxiliary function has
-- no qualifiers -- i.e., if it is equivalent to '[e]' -- we
-- avoid the construction of the singleton list by calling '(:)'
-- instead of '(++)' and 'map' in place of 'concatMap', respectively.

Finn Teegen's avatar
Finn Teegen committed
862
dsListComp :: Position -> Expression PredType -> [Statement PredType]
Finn Teegen's avatar
Finn Teegen committed
863
           -> DsM (Expression PredType)
Finn Teegen's avatar
Finn Teegen committed
864
865
866
dsListComp p e []     =
  dsExpr p (List (predType $ listType $ typeOf e) [e])
dsListComp p e (q:qs) = dsQual p q (ListCompr e qs)
867

Finn Teegen's avatar
Finn Teegen committed
868
869
dsQual :: Position -> Statement PredType -> Expression PredType
       -> DsM (Expression PredType)
Finn Teegen's avatar
Finn Teegen committed
870
871
872
873
dsQual p (StmtExpr   b) e =
  dsExpr p (IfThenElse b e (List (predType $ typeOf e) []))
dsQual p (StmtDecl  ds) e = dsExpr p (Let ds e)
dsQual p (StmtBind t l) e
Finn Teegen's avatar
Finn Teegen committed
874
875
876
877
  | isVariablePattern t = dsExpr p (qualExpr t e l)
  | otherwise = do
    v <- freshVar "_#var" t
    l' <- freshVar "_#var" e
Finn Teegen's avatar
Finn Teegen committed
878
879
    dsExpr p (apply (prelFoldr (typeOf t) (typeOf e))
      [foldFunct v l' e, List (predType $ typeOf e) [], l])
880
  where
Finn Teegen's avatar
Finn Teegen committed
881
882
  qualExpr v (ListCompr e1 []) l1
    = apply (prelMap (typeOf v) (typeOf e1)) [Lambda [v] e1, l1]
Finn Teegen's avatar
Finn Teegen committed
883
  qualExpr v e1                  l1
Finn Teegen's avatar
Finn Teegen committed
884
    = apply (prelConcatMap (typeOf v) (elemType $ typeOf e1)) [Lambda [v] e1, l1]
885
  foldFunct v l1 e1
Finn Teegen's avatar
Finn Teegen committed
886
887
    = Lambda (map (uncurry VariablePattern) [v, l1])
       (Case Rigid (uncurry mkVar v)
Finn Teegen's avatar
Finn Teegen committed
888
889
          [ caseAlt p t (append e1 (uncurry mkVar l1))
          , caseAlt p (uncurry VariablePattern v) (uncurry mkVar l1)])
890

Finn Teegen's avatar
Finn Teegen committed
891
892
893
  append (ListCompr e1 []) l1 = apply (prelCons (typeOf e1)) [e1, l1]
  append e1                l1 = apply (prelAppend (elemType $ typeOf e1)) [e1, l1]
  prelCons ty                 = Constructor (predType $ consType ty) $ qConsId
894

895
896
897
898
-- -----------------------------------------------------------------------------
-- Desugaring of Lists, labels, fields, and literals
-- -----------------------------------------------------------------------------

Finn Teegen's avatar
Finn Teegen committed