Desugar.hs 48.5 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
Finn Teegen's avatar
Finn Teegen committed
8
                     2016        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
40
41
42
43
44
45
46
47
48

  * Applications 'N x' in patterns and expressions, where 'N' is a
    newtype constructor, are replaced by a 'x'. Note that neither the
    newtype declaration itself nor partial applications of newtype
    constructors are changed.
    It were possible to replace partial applications of newtype constructor
    by 'Prelude.id'.
    However, our solution yields a more accurate output when the result
    of a computation includes partial applications.

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

51
52
53
54
55
56
57
58
59
  * 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.
60
61
62

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

67
#if __GLASGOW_HASKELL__ < 710
68
import           Control.Applicative        ((<$>), (<*>))
69
#endif
70
import           Control.Arrow              (first, second)
Finn Teegen's avatar
Finn Teegen committed
71
72
73
import           Control.Monad              (liftM2, mplus)
import           Control.Monad.Extra        (concatMapM)
import           Control.Monad.ListM        (mapAccumM)
74
import qualified Control.Monad.State as S   (State, runState, gets, modify)
75
import           Data.Foldable              (foldrM)
Finn Teegen's avatar
Finn Teegen committed
76
77
import           Data.List                  ( (\\), elemIndex, nub, partition
                                            , tails )
78
import           Data.Maybe                 (fromMaybe)
79
80
81
82
83
84
85
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
86
import Base.CurryTypes
87
import Base.Messages (internalError)
Finn Teegen's avatar
Finn Teegen committed
88
import Base.TypeExpansion
89
import Base.Types
Finn Teegen's avatar
Finn Teegen committed
90
import Base.TypeSubst
91
import Base.Typing
Finn Teegen's avatar
Finn Teegen committed
92
import Base.Utils (fst3)
93

Finn Teegen's avatar
Finn Teegen committed
94
import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTypeInfo)
95
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
96

97
98
99
100
-- 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
101
-- Since they cannot occur in local declaration groups, they are filtered
102
103
104
-- 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
105
106
107
desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module PredType
        -> (Module PredType, ValueEnv)
desugar xs vEnv tcEnv (Module ps m es is ds)
108
109
  = (Module ps m es is ds', valueEnv s')
  where (ds', s') = S.runState (desugarModuleDecls ds)
Finn Teegen's avatar
Finn Teegen committed
110
                               (DesugarState m xs tcEnv vEnv 1)
111
112
113
114
115
116
117
118
119

-- ---------------------------------------------------------------------------
-- 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
120
121
122
123
124
125
126
-- 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
127
128
  , valueEnv    :: ValueEnv         -- will be extended
  , nextId      :: Integer          -- counter
129
130
131
132
133
134
135
  }

type DsM a = S.State DesugarState a

getModuleIdent :: DsM ModuleIdent
getModuleIdent = S.gets moduleIdent

136
137
checkNegativeLitsExtension :: DsM Bool
checkNegativeLitsExtension = S.gets (\s -> NegativeLiterals `elem` extensions s)
138
139
140
141
142
143
144
145
146
147

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
148
  S.modify $ \s -> s { nextId = succ nid }
149
150
151
152
153
154
  return nid

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

155
-- Create a fresh variable ident for a given prefix with a monomorphic type
Finn Teegen's avatar
Finn Teegen committed
156
157
158
159
freshVar :: Typeable t => String -> t -> DsM (PredType, Ident)
freshVar prefix t = do
  v <- (mkIdent . (prefix ++) . show) <$> getNextId
  return (predType $ typeOf t, v)
160

161
162
163
-- ---------------------------------------------------------------------------
-- Desugaring
-- ---------------------------------------------------------------------------
164

Finn Teegen's avatar
Finn Teegen committed
165
desugarModuleDecls :: [Decl PredType] -> DsM [Decl PredType]
166
desugarModuleDecls ds = do
Finn Teegen's avatar
Finn Teegen committed
167
168
169
  ds'   <- concatMapM dsRecordDecl ds -- convert record decls to data decls
  ds''  <- mapM dsClassAndInstanceDecl ds'
  ds''' <- dsDeclGroup ds''
170
  return $ filter (not . liftM2 (||) isValueDecl isTypeSig) ds'' ++ ds'''
Finn Teegen's avatar
Finn Teegen committed
171
172
173
174
175
176
177
178
179
180
181
182

-- -----------------------------------------------------------------------------
-- 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
183

184
185
186
187
188
189
190
191
192
-- -----------------------------------------------------------------------------
-- 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.
193

194
195
-- Generate selector functions for record labels and replace record
-- constructor declarations by ordinary constructor declarations.
Finn Teegen's avatar
Finn Teegen committed
196
dsRecordDecl :: Decl PredType -> DsM [Decl PredType]
Finn Teegen's avatar
Finn Teegen committed
197
dsRecordDecl (DataDecl p tc tvs cs clss) = do
198
199
200
  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
201
202
  return $ DataDecl p tc tvs (map unlabelConstr cs) clss : selFuns
dsRecordDecl (NewtypeDecl p tc tvs nc clss) = do
203
204
205
  m <- getModuleIdent
  let qc = qualifyWith m (nconstrId nc)
  selFun <- mapM (genSelFun p [qc]) (nrecordLabels nc)
Finn Teegen's avatar
Finn Teegen committed
206
  return $ NewtypeDecl p tc tvs (unlabelNewConstr nc) clss : selFun
Finn Teegen's avatar
Finn Teegen committed
207
dsRecordDecl d = return [d]
208
209

-- Generate a selector function for a single record label
Finn Teegen's avatar
Finn Teegen committed
210
211
212
213
214
215
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
216
217
218

-- 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
219
genSelEqn :: Position -> Ident -> QualIdent -> DsM [Equation PredType]
220
genSelEqn p l qc = do
Finn Teegen's avatar
Finn Teegen committed
221
222
223
  vEnv <- getValueEnv
  let (ls, ty) = conType qc vEnv
      (tys, ty0) = arrowUnapply (instType ty)
224
  case elemIndex l ls of
Finn Teegen's avatar
Finn Teegen committed
225
226
227
228
    Just n  -> do
      vs <- mapM (freshVar "_#rec") tys
      let pat = constrPattern (predType ty0) qc vs
      return [mkEquation p l [pat] (uncurry mkVar (vs !! n))]
229
230
231
232
    Nothing -> return []

-- Remove any labels from a data constructor declaration
unlabelConstr :: ConstrDecl -> ConstrDecl
Finn Teegen's avatar
Finn Teegen committed
233
unlabelConstr (RecordDecl p evs cx c fs) = ConstrDecl p evs cx c tys
234
  where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]
Finn Teegen's avatar
Finn Teegen committed
235
unlabelConstr c                          = c
236
237
238

-- Remove any labels from a newtype constructor declaration
unlabelNewConstr :: NewConstrDecl -> NewConstrDecl
Finn Teegen's avatar
Finn Teegen committed
239
240
unlabelNewConstr (NewRecordDecl p nc (_, ty)) = NewConstrDecl p nc ty
unlabelNewConstr c                            = c
241
242
243
244
245
246
247
248
249

-- -----------------------------------------------------------------------------
-- 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
250
dsDeclGroup :: [Decl PredType] -> DsM [Decl PredType]
251
dsDeclGroup ds = concatMapM dsDeclLhs (filter isValueDecl ds) >>= mapM dsDeclRhs
252

Finn Teegen's avatar
Finn Teegen committed
253
dsDeclLhs :: Decl PredType -> DsM [Decl PredType]
254
dsDeclLhs (PatternDecl p t rhs) = do
255
  (ds', t') <- dsPat p [] t
256
257
  dss'      <- mapM dsDeclLhs ds'
  return $ PatternDecl p t' rhs : concat dss'
Finn Teegen's avatar
Finn Teegen committed
258
dsDeclLhs (ExternalDecl   p vs) = return $ map (genForeignDecl p) vs
259
260
dsDeclLhs d                     = return [d]

Finn Teegen's avatar
Finn Teegen committed
261
262
263
264
genForeignDecl :: Position -> Var PredType -> Decl PredType
genForeignDecl p (Var pty v) =
  ForeignDecl p CallConvPrimitive (Just $ idName v) pty v $
    fromType identSupply $ typeOf pty
265

266
-- TODO: Check if obsolete and remove
267
268
269
270
271
272
273
274
275
-- 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.

276
-- Desugaring of the right-hand-side of declarations
Finn Teegen's avatar
Finn Teegen committed
277
278
279
280
281
282
dsDeclRhs :: Decl PredType -> DsM (Decl PredType)
dsDeclRhs (FunctionDecl     p pty f eqs) =
  FunctionDecl p pty f <$> mapM dsEquation eqs
dsDeclRhs (PatternDecl          p t rhs) = PatternDecl p t <$> dsRhs p id rhs
dsDeclRhs (ForeignDecl p cc ie pty f ty) =
  return $ ForeignDecl p cc ie' pty f ty
283
  where ie' = ie `mplus` Just (idName f)
Finn Teegen's avatar
Finn Teegen committed
284
285
286
dsDeclRhs fs@(FreeDecl              _ _) = return fs
dsDeclRhs _                              =
  error "Desugar.dsDeclRhs: no pattern match"
287

288
-- Desugaring of an equation
Finn Teegen's avatar
Finn Teegen committed
289
dsEquation :: Equation PredType -> DsM (Equation PredType)
290
dsEquation (Equation p lhs rhs) = do
291
292
293
294
295
296
  (     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'
297
298
  where (f, ts) = flatLhs lhs

299
300
301
-- 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
302
constrain :: [Expression PredType] -> Expression PredType -> Expression PredType
303
constrain cs e = if null cs then e else foldr1 (&) cs &> e
304
305
306
307
308
309
310
311
312
313
314
315
316

-- -----------------------------------------------------------------------------
-- 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
317
318
dsRhs :: Position -> (Expression PredType -> Expression PredType)
      -> Rhs PredType -> DsM (Rhs PredType)
319
dsRhs p f rhs =     expandRhs (prelFailed (typeOf rhs)) f rhs
320
321
322
323
                >>= dsExpr pRhs
                >>= return . simpleRhs pRhs
  where
  pRhs = fromMaybe p (getRhsPosition rhs)
324

Finn Teegen's avatar
Finn Teegen committed
325
326
expandRhs :: Expression PredType -> (Expression PredType -> Expression PredType)
          -> Rhs PredType -> DsM (Expression PredType)
327
328
329
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
330
331
332
333
expandGuards :: Expression PredType -> [CondExpr PredType]
             -> DsM (Expression PredType)
expandGuards e0 es =
  return $ if boolGuards es then foldr mkIfThenElse e0 es else mkCond es
334
  where
Finn Teegen's avatar
Finn Teegen committed
335
  mkIfThenElse (CondExpr _ g e) = IfThenElse g e
336
  mkCond [CondExpr _ g e] = g &> e
337
338
  mkCond _                = error "Desugar.expandGuards.mkCond: non-unary list"

Finn Teegen's avatar
Finn Teegen committed
339
340
341
boolGuards :: [CondExpr PredType] -> Bool
boolGuards []                    = False
boolGuards (CondExpr _ g _ : es) = not (null es) || typeOf g == boolType
342
343

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

348
getRhsPosition :: Rhs a -> Maybe Position
349
getRhsPosition (SimpleRhs p _ _) = Just p
350
getRhsPosition (GuardedRhs  _ _) = Nothing
351

352
353
354
355
-- -----------------------------------------------------------------------------
-- Desugaring of non-linear patterns
-- -----------------------------------------------------------------------------

356
357
358
359
-- 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.
360
-- Non-linear patterns inside single functional patterns are not desugared,
361
-- as this special case is handled later.
Finn Teegen's avatar
Finn Teegen committed
362
363
dsNonLinearity :: [Pattern PredType]
               -> DsM ([Expression PredType], [Pattern PredType])
364
365
366
367
dsNonLinearity ts = do
  ((_, cs), ts') <- mapAccumM dsNonLinear (Set.empty, []) ts
  return (reverse cs, ts')

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

Finn Teegen's avatar
Finn Teegen committed
370
371
372
dsNonLinear :: NonLinearEnv -> Pattern PredType
            -> DsM (NonLinearEnv, Pattern PredType)
dsNonLinear env l@(LiteralPattern        _ _) = return (env, l)
Finn Teegen's avatar
Finn Teegen committed
373
dsNonLinear env n@(NegativePattern       _ _) = return (env, n)
Finn Teegen's avatar
Finn Teegen committed
374
dsNonLinear env t@(VariablePattern       _ v)
375
  | isAnonId v         = return (env, t)
376
  | v `Set.member` vis = do
Finn Teegen's avatar
Finn Teegen committed
377
378
    v' <- freshVar "_#nonlinear" t
    return ((vis, mkStrictEquality v v' : eqs), uncurry VariablePattern v')
379
380
  | otherwise          = return ((Set.insert v vis, eqs), t)
  where (vis, eqs) = env
Finn Teegen's avatar
Finn Teegen committed
381
382
383
dsNonLinear env (ConstructorPattern pty c ts) = second (ConstructorPattern pty c)
                                                <$> mapAccumM dsNonLinear env ts
dsNonLinear env (InfixPattern   pty t1 op t2) = do
384
385
  (env1, t1') <- dsNonLinear env  t1
  (env2, t2') <- dsNonLinear env1 t2
Finn Teegen's avatar
Finn Teegen committed
386
  return (env2, InfixPattern pty t1' op t2')
387
388
dsNonLinear env (ParenPattern            t) = second ParenPattern
                                              <$> dsNonLinear env t
Finn Teegen's avatar
Finn Teegen committed
389
390
dsNonLinear env (RecordPattern      pty c fs) =
  second (RecordPattern pty c) <$> mapAccumM (dsField dsNonLinear) env fs
Finn Teegen's avatar
Finn Teegen committed
391
dsNonLinear env (TuplePattern             ts) = second TuplePattern
Finn Teegen's avatar
Finn Teegen committed
392
                                                <$> mapAccumM dsNonLinear env ts
Finn Teegen's avatar
Finn Teegen committed
393
dsNonLinear env (ListPattern          pty ts) = second (ListPattern pty)
Finn Teegen's avatar
Finn Teegen committed
394
                                                <$> mapAccumM dsNonLinear env ts
Finn Teegen's avatar
Finn Teegen committed
395
dsNonLinear env (AsPattern               v t) = do
Finn Teegen's avatar
Finn Teegen committed
396
397
398
  let pty = predType $ typeOf t
  (env1, VariablePattern _ v') <- dsNonLinear env (VariablePattern pty v)
  (env2, t') <- dsNonLinear env1 t
399
  return (env2, AsPattern v' t')
Finn Teegen's avatar
Finn Teegen committed
400
dsNonLinear env (LazyPattern               t) = second LazyPattern
Finn Teegen's avatar
Finn Teegen committed
401
402
403
                                                <$> dsNonLinear env t
dsNonLinear env fp@(FunctionPattern    _ _ _) = dsNonLinearFuncPat env fp
dsNonLinear env fp@(InfixFuncPattern _ _ _ _) = dsNonLinearFuncPat env fp
404

Finn Teegen's avatar
Finn Teegen committed
405
406
dsNonLinearFuncPat :: NonLinearEnv -> Pattern PredType
                   -> DsM (NonLinearEnv, Pattern PredType)
407
dsNonLinearFuncPat (vis, eqs) fp = do
Finn Teegen's avatar
Finn Teegen committed
408
409
410
411
412
413
414
415
416
417
418
419
  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
420
substPat _ n@(NegativePattern       _ _) = n
Finn Teegen's avatar
Finn Teegen committed
421
422
423
424
425
426
427
428
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)
429
  where substField (Field pos l pat) = Field pos l (substPat s pat)
Finn Teegen's avatar
Finn Teegen committed
430
substPat s (TuplePattern             ps) = TuplePattern
Finn Teegen's avatar
Finn Teegen committed
431
                                         $ map (substPat s) ps
Finn Teegen's avatar
Finn Teegen committed
432
substPat s (ListPattern            a ps) = ListPattern a
Finn Teegen's avatar
Finn Teegen committed
433
434
435
                                         $ 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
436
substPat s (LazyPattern               p) = LazyPattern (substPat s p)
Finn Teegen's avatar
Finn Teegen committed
437
438
439
440
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)
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459

-- -----------------------------------------------------------------------------
-- 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
460
461
462
dsFunctionalPatterns
  :: Position -> [Pattern PredType]
  -> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])
463
464
465
466
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
467
  let (ds, cs) = genFPExpr p (concatMap patternVars ts') (reverse bs)
468
469
470
  -- return (declarations, constraints, desugared patterns)
  return (ds, cs, ts')

Finn Teegen's avatar
Finn Teegen committed
471
type LazyBinding = (Pattern PredType, (PredType, Ident))
472

Finn Teegen's avatar
Finn Teegen committed
473
474
475
elimFP :: [LazyBinding] -> Pattern PredType
       -> DsM ([LazyBinding], Pattern PredType)
elimFP bs p@(LiteralPattern        _ _) = return (bs, p)
Finn Teegen's avatar
Finn Teegen committed
476
elimFP bs p@(NegativePattern       _ _) = return (bs, p)
Finn Teegen's avatar
Finn Teegen committed
477
478
479
480
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
481
482
  (bs1, t1') <- elimFP bs  t1
  (bs2, t2') <- elimFP bs1 t2
Finn Teegen's avatar
Finn Teegen committed
483
484
485
486
  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
487
elimFP bs (TuplePattern             ts) = second TuplePattern
Finn Teegen's avatar
Finn Teegen committed
488
                                          <$> mapAccumM elimFP bs ts
Finn Teegen's avatar
Finn Teegen committed
489
elimFP bs (ListPattern          pty ts) = second (ListPattern pty)
Finn Teegen's avatar
Finn Teegen committed
490
491
                                          <$> mapAccumM elimFP bs ts
elimFP bs (AsPattern               v t) = second (AsPattern   v) <$> elimFP bs t
Finn Teegen's avatar
Finn Teegen committed
492
elimFP bs (LazyPattern               t) = second LazyPattern <$> elimFP bs t
Finn Teegen's avatar
Finn Teegen committed
493
494
495
496
497
498
499
500
501
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])
502
503
504
genFPExpr p vs bs
  | null bs   = ([]               , [])
  | null free = ([]               , cs)
Finn Teegen's avatar
Finn Teegen committed
505
  | otherwise = ([FreeDecl p (map (\(v, _, pty) -> Var pty v) free)], cs)
506
  where
Finn Teegen's avatar
Finn Teegen committed
507
508
509
510
511
512
513
514
  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
515
fp2Expr (NegativePattern         pty l) = (Literal pty (negateLiteral l), [])
Finn Teegen's avatar
Finn Teegen committed
516
517
fp2Expr (VariablePattern         pty v) = (mkVar pty v, [])
fp2Expr (ConstructorPattern   pty c ts) =
518
  let (ts', ess) = unzip $ map fp2Expr ts
Finn Teegen's avatar
Finn Teegen committed
519
520
  in  (apply (Constructor pty c) ts', concat ess)
fp2Expr (InfixPattern   pty t1 op t2) =
521
522
  let (t1', es1) = fp2Expr t1
      (t2', es2) = fp2Expr t2
Finn Teegen's avatar
Finn Teegen committed
523
524
525
      pty' = predType $ TypeArrow (typeOf t1') $ TypeArrow (typeOf t2') $ unpredType pty
  in  (InfixApply t1' (InfixConstr pty' op) t2', es1 ++ es2)
fp2Expr (ParenPattern                t) = first Paren (fp2Expr t)
Finn Teegen's avatar
Finn Teegen committed
526
fp2Expr (TuplePattern               ts) =
527
  let (ts', ess) = unzip $ map fp2Expr ts
Finn Teegen's avatar
Finn Teegen committed
528
529
  in  (Tuple ts', concat ess)
fp2Expr (ListPattern            pty ts) =
530
  let (ts', ess) = unzip $ map fp2Expr ts
Finn Teegen's avatar
Finn Teegen committed
531
  in  (List pty ts', concat ess)
Finn Teegen's avatar
Finn Teegen committed
532
fp2Expr (FunctionPattern      pty f ts) =
533
  let (ts', ess) = unzip $ map fp2Expr ts
Finn Teegen's avatar
Finn Teegen committed
534
535
  in  (apply (Variable pty f) ts', concat ess)
fp2Expr (InfixFuncPattern pty t1 op t2) =
536
537
  let (t1', es1) = fp2Expr t1
      (t2', es2) = fp2Expr t2
Finn Teegen's avatar
Finn Teegen committed
538
539
540
      pty' = predType $ TypeArrow (typeOf t1') $ TypeArrow (typeOf t2') $ unpredType pty
  in  (InfixApply t1' (InfixOp pty' op) t2', es1 ++ es2)
fp2Expr (AsPattern                 v t) =
541
  let (t', es) = fp2Expr t
Finn Teegen's avatar
Finn Teegen committed
542
543
544
      pty = predType $ typeOf t
  in  (mkVar pty v, (t' =:<= mkVar pty v) : es)
fp2Expr (RecordPattern        pty c fs) =
545
546
  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
547
548
  in  (Record pty c fs', concat ess)
fp2Expr t                               = internalError $
549
550
551
  "Desugar.fp2Expr: Unexpected constructor term: " ++ show t

-- -----------------------------------------------------------------------------
552
-- Desugaring of ordinary patterns
553
-- -----------------------------------------------------------------------------
554
555
556
557
558
559
560
561

-- 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'.

562
563
564
565
566
567
568
569
570
571
572
573
574
-- 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
575
576
dsLiteralPat :: PredType -> Literal
             -> Either (Pattern PredType) (Pattern PredType)
Finn Teegen's avatar
Finn Teegen committed
577
578
dsLiteralPat pty c@(Char _) = Right (LiteralPattern pty c)
dsLiteralPat pty (Int i) =
Finn Teegen's avatar
Finn Teegen committed
579
580
581
  Right (LiteralPattern pty (fixLiteral (unpredType pty)))
  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
        fixLiteral ty
Finn Teegen's avatar
Finn Teegen committed
582
583
584
585
586
          | 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
587
588
589
590
591
592
593
  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
594
dsPat p ds (NegativePattern     pty l) =
Finn Teegen's avatar
Finn Teegen committed
595
596
  dsPat p ds (LiteralPattern pty (negateLiteral l))
dsPat p ds (ConstructorPattern pty c [t]) = do
597
598
  isNc <- isNewtypeConstr c
  if isNc then dsPat p ds t else second (constrPat c) <$> dsPat p ds t
Finn Teegen's avatar
Finn Teegen committed
599
600
601
602
603
  where constrPat c' t' = ConstructorPattern pty c' [t']
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])
604
dsPat p ds (ParenPattern           t) = dsPat p ds t
Finn Teegen's avatar
Finn Teegen committed
605
606
607
608
609
610
611
612
613
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
614
615
dsPat p ds (TuplePattern          ts) =
  dsPat p ds (ConstructorPattern pty (qTupleId $ length ts) ts)
Finn Teegen's avatar
Finn Teegen committed
616
  where pty = predType (tupleType (map typeOf ts))
Finn Teegen's avatar
Finn Teegen committed
617
618
619
620
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']
621
dsPat p ds (AsPattern            v t) = dsAs p v <$> dsPat p ds t
Finn Teegen's avatar
Finn Teegen committed
622
dsPat p ds (LazyPattern            t) = dsLazy p ds t
Finn Teegen's avatar
Finn Teegen committed
623
dsPat p ds (FunctionPattern    pty f ts) = second (FunctionPattern pty f)
624
                                        <$> mapAccumM (dsPat p) ds ts
Finn Teegen's avatar
Finn Teegen committed
625
626
dsPat p ds (InfixFuncPattern pty t1 f t2) =
  dsPat p ds (FunctionPattern pty f [t1, t2])
627

Finn Teegen's avatar
Finn Teegen committed
628
629
dsAs :: Position -> Ident -> ([Decl PredType], Pattern PredType)
     -> ([Decl PredType], Pattern PredType)
630
dsAs p v (ds, t) = case t of
Finn Teegen's avatar
Finn Teegen committed
631
632
633
634
  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)
635

Finn Teegen's avatar
Finn Teegen committed
636
dsLazy :: Position -> [Decl PredType] -> Pattern PredType
Finn Teegen's avatar
Finn Teegen committed
637
       -> DsM ([Decl PredType], Pattern PredType)
Finn Teegen's avatar
Finn Teegen committed
638
dsLazy p ds t = case t of
Finn Teegen's avatar
Finn Teegen committed
639
  VariablePattern _ _ -> return (ds, t)
Finn Teegen's avatar
Finn Teegen committed
640
641
642
643
644
645
  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')
646

Finn Teegen's avatar
Finn Teegen committed
647
{-
648
649
650
-- -----------------------------------------------------------------------------
-- Desugaring of expressions
-- -----------------------------------------------------------------------------
651

652
653
-- Record construction expressions are transformed into normal
-- constructor applications by rearranging fields in the order of the
654
-- record's declaration, passing `Prelude.unknown` in place of
655
656
657
658
659
660
-- 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
661
662
-- 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
663
664
665
666
667
668
-}
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
669
  | otherwise                = return var
Finn Teegen's avatar
Finn Teegen committed
670
dsExpr _ c@(Constructor _ _) = return c
671
dsExpr p (Paren           e) = dsExpr p e
Finn Teegen's avatar
Finn Teegen committed
672
673
674
675
676
677
678
679
680
681
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)
682
dsExpr p (RecordUpdate e fs) = do
Finn Teegen's avatar
Finn Teegen committed
683
  alts  <- constructors tc >>= concatMapM updateAlt
Finn Teegen's avatar
Finn Teegen committed
684
  dsExpr p $ Case Flex e (map (uncurry (caseAlt p)) alts)
Finn Teegen's avatar
Finn Teegen committed
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
  where ty = typeOf e
        pty = predType ty
        TypeConstructor tc = arrowBase ty
        updateAlt (RecordConstr c _ _ ls tys)
          | all (`elem` qls) (map fieldLabel fs)= do
            vs <- mapM (freshVar "_#rec") tys
            let qc = qualifyLike tc c
                pat = constrPattern pty qc vs
                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)]
          where qls = map (qualifyLike tc) ls
        updateAlt _ = return []
Finn Teegen's avatar
Finn Teegen committed
700
dsExpr p (Tuple      es) = apply (Constructor pty $ qTupleId $ length es) <$> mapM (dsExpr p) es
Finn Teegen's avatar
Finn Teegen committed
701
702
  where pty = predType (foldr TypeArrow (tupleType tys) tys)
        tys = map typeOf es
Finn Teegen's avatar
Finn Teegen committed
703
704
705
706
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
707
708
709
dsExpr p (EnumFrom              e) = Apply (prelEnumFrom (typeOf e))
                                     <$> dsExpr p e
dsExpr p (EnumFromThen      e1 e2) = apply (prelEnumFromThen (typeOf e1))
710
                                     <$> mapM (dsExpr p) [e1, e2]
Finn Teegen's avatar
Finn Teegen committed
711
dsExpr p (EnumFromTo        e1 e2) = apply (prelEnumFromTo (typeOf e1))
712
                                     <$> mapM (dsExpr p) [e1, e2]
Finn Teegen's avatar
Finn Teegen committed
713
dsExpr p (EnumFromThenTo e1 e2 e3) = apply (prelEnumFromThenTo (typeOf e1))
714
                                     <$> mapM (dsExpr p) [e1, e2, e3]
Finn Teegen's avatar
Finn Teegen committed
715
dsExpr p (UnaryMinus            e) = do
716
  e' <- dsExpr p e
717
718
  negativeLitsEnabled <- checkNegativeLitsExtension
  return $ case e' of
Finn Teegen's avatar
Finn Teegen committed
719
720
721
    Literal pty l | negativeLitsEnabled -> Literal pty $ negateLiteral l
    _                                   -> Apply (prelNegate $ typeOf e') e'
dsExpr p (Apply (Constructor pty c) e) = do
722
  isNc <- isNewtypeConstr c
Finn Teegen's avatar
Finn Teegen committed
723
  if isNc then dsExpr p e else Apply (Constructor pty c) <$> dsExpr p e
724
dsExpr p (Apply e1 e2) = Apply <$> dsExpr p e1 <*> dsExpr p e2
725
726
727
728
729
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']
730
dsExpr p (LeftSection  e op) = Apply <$> dsExpr p (infixOp op) <*> dsExpr p e
731
732
dsExpr p (RightSection op e) = do
  op' <- dsExpr p (infixOp op)
733
  e'  <- dsExpr p e
Finn Teegen's avatar
Finn Teegen committed
734
735
  return $ apply (prelFlip ty1 ty2 ty3) [op', e']
  where TypeArrow ty1 (TypeArrow ty2 ty3) = typeOf (infixOp op)
Finn Teegen's avatar
Finn Teegen committed
736
dsExpr p expr@(Lambda ts e) = do
Finn Teegen's avatar
Finn Teegen committed
737
  (pty, f) <- freshVar "_#lambda" expr
Finn Teegen's avatar
Finn Teegen committed
738
  dsExpr p $ Let [funDecl NoPos pty f ts e] $ mkVar pty f
739
740
dsExpr p (Let ds e) = do
  ds' <- dsDeclGroup ds
741
  e'  <- dsExpr p e
742
  return (if null ds' then e' else Let ds' e')
743
dsExpr p (Do              sts e) = dsDo sts e >>= dsExpr p
Finn Teegen's avatar
Finn Teegen committed
744
dsExpr p (IfThenElse e1 e2 e3) = do
745
746
747
  e1' <- dsExpr p e1
  e2' <- dsExpr p e2
  e3' <- dsExpr p e3
Finn Teegen's avatar
Finn Teegen committed
748
749
  return $ Case Rigid e1' [caseAlt p truePat e2', caseAlt p falsePat e3']
dsExpr p (Case ct e alts) = dsCase p ct e alts
750

Finn Teegen's avatar
Finn Teegen committed
751
752
753
754
755
756
757
758
-- 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

759
760
dsTypeExpr :: TypeExpr -> DsM TypeExpr
dsTypeExpr ty = do
Finn Teegen's avatar
Finn Teegen committed
761
  m <- getModuleIdent
762
  tcEnv <- getTyConsEnv
Finn Teegen's avatar
Finn Teegen committed
763
  return $ fromType (typeVariables ty) (expandType m tcEnv (toType [] ty))
764

765
766
767
-- -----------------------------------------------------------------------------
-- Desugaring of case expressions
-- -----------------------------------------------------------------------------
768

769
770
771
772
773
774
775
776
-- 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
777
778
779
dsCase :: Position -> CaseType -> Expression PredType -> [Alt PredType]
       -> DsM (Expression PredType)
dsCase p ct e alts
Finn Teegen's avatar
Finn Teegen committed
780
  | null alts = internalError "Desugar.dsCase: empty list of alternatives"
781
782
783
  | otherwise = do
    m  <- getModuleIdent
    e' <- dsExpr p e
Finn Teegen's avatar
Finn Teegen committed
784
    v  <- freshVar "_#case" e
785
786
787
788
    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
789
  mkCase m (pty, v) e' bs
Finn Teegen's avatar
Finn Teegen committed
790
791
    | v `elem` qfv m bs = Let [varDecl p pty v e'] (Case ct (mkVar pty v) bs)
    | otherwise         = Case ct e' bs
792

Finn Teegen's avatar
Finn Teegen committed
793
dsAltLhs :: Alt PredType -> DsM (Alt PredType)
794
dsAltLhs (Alt p t rhs) = do
795
  (ds', t') <- dsPat p [] t
796
797
  return $ Alt p t' (addDecls ds' rhs)

Finn Teegen's avatar
Finn Teegen committed
798
dsAltRhs :: Alt PredType -> DsM (Alt PredType)
799
dsAltRhs (Alt p t rhs) = Alt p t <$> dsRhs p id rhs
800

Finn Teegen's avatar
Finn Teegen committed
801
802
expandAlt :: (PredType, Ident) -> CaseType -> [Alt PredType]
          -> DsM (Alt PredType)
803
expandAlt _ _  []                   = error "Desugar.expandAlt: empty list"
804
expandAlt v ct (Alt p t rhs : alts) = caseAlt p t <$> expandRhs e0 id rhs
805
  where
Finn Teegen's avatar
Finn Teegen committed
806
  e0 | ct == Flex || null compAlts = prelFailed (typeOf rhs)
Finn Teegen's avatar
Finn Teegen committed
807
     | otherwise = Case ct (uncurry mkVar v) compAlts
Finn Teegen's avatar
Finn Teegen committed
808
  compAlts = filter (isCompatible t . altPattern) alts
809
810
  altPattern (Alt _ t1 _) = t1

Finn Teegen's avatar
Finn Teegen committed
811
812
813
814
815
816
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)
817
  = and ((c1 == c2) : zipWith isCompatible ts1 ts2)
Finn Teegen's avatar
Finn Teegen committed
818
819
isCompatible (LiteralPattern _ l1) (LiteralPattern _ l2) = l1 == l2
isCompatible _ _ = False
820

821
-- -----------------------------------------------------------------------------
822
-- Desugaring of do-Notation
823
-- -----------------------------------------------------------------------------
824

825
826
827
828
-- The do-notation is desugared in the following way:
--
-- `dsDo([]         , e)` -> `e`
-- `dsDo(e'     ; ss, e)` -> `e' >>        dsDo(ss, e)`
829
830
831
-- `dsDo(p <- e'; ss, e)` -> `e' >>= \v -> case v of
--                                           p -> dsDo(ss, e)
--                                           _ -> fail "..."`
832
-- `dsDo(let ds ; ss, e)` -> `let ds in    dsDo(ss, e)`
833
834
dsDo :: [Statement PredType] -> Expression PredType -> DsM (Expression PredType)
dsDo sts e = foldrM dsStmt e sts
Finn Teegen's avatar
Finn Teegen committed
835

836
dsStmt :: Statement PredType -> Expression PredType -> DsM (Expression PredType)
Finn Teegen's avatar
Finn Teegen committed
837
838
839
dsStmt (StmtExpr   e1) e' =
  return $ apply (prelBind_ (typeOf e1) (typeOf e')) [e1, e']
dsStmt (StmtBind t e1) e' = do
840
  v <- freshVar "_#var" t
Finn Teegen's avatar
Finn Teegen committed
841
842
  let func = Lambda [uncurry VariablePattern v] $
               Case Rigid (uncurry mkVar v)
843
844
845
846
                 [ caseAlt NoPos t e'
                 , caseAlt NoPos (uncurry VariablePattern v)
                     (failedPatternMatch $ typeOf e')
                 ]
Finn Teegen's avatar
Finn Teegen committed
847
848
  return $ apply (prelBind (typeOf e1) (typeOf t) (typeOf e')) [e1, func]
  where failedPatternMatch ty =
849
          apply (prelFail ty)
Finn Teegen's avatar
Finn Teegen committed
850
851
            [Literal predStringType $ String "Pattern match failed!"]
dsStmt (StmtDecl   ds) e' = return $ Let ds e'
852

853
-- -----------------------------------------------------------------------------
854
-- Desugaring of List Comprehensions
855
856
-- -----------------------------------------------------------------------------

857
858
859
860
861
862
863
864
865
866
867
868
869
870
-- 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.
871
-- TODO: Unfortunately, this is incorrect.
872
873
874
875
876
877
878
879
880
881
882

-- 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
883
dsListComp :: Position -> Expression PredType -> [Statement PredType]
Finn Teegen's avatar
Finn Teegen committed
884
           -> DsM (Expression PredType)
Finn Teegen's avatar
Finn Teegen committed
885
886
887
dsListComp p e []     =
  dsExpr p (List (predType $ listType $ typeOf e) [e])
dsListComp p e (q:qs) = dsQual p q (ListCompr e qs)
888

Finn Teegen's avatar
Finn Teegen committed
889
890
dsQual :: Position -> Statement PredType -> Expression PredType
       -> DsM (Expression PredType)
Finn Teegen's avatar
Finn Teegen committed
891
892
893
894
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
895
896
897
898
  | 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
899
900
    dsExpr p (apply (prelFoldr (typeOf t) (typeOf e))
      [foldFunct v l' e, List (predType $ typeOf e) [], l])
901
  where
Finn Teegen's avatar
Finn Teegen committed
902
903
  qualExpr v (ListCompr e1 []) l1
    = apply (prelMap (typeOf v) (typeOf e1)) [Lambda [v] e1, l1]
Finn Teegen's avatar
Finn Teegen committed
904
  qualExpr v e1                  l1
Finn Teegen's avatar
Finn Teegen committed
905
    = apply (prelConcatMap (typeOf v) (elemType $ typeOf e1)) [Lambda [v] e1, l1]
906
  foldFunct v l1 e1
Finn Teegen's avatar
Finn Teegen committed
907
908
    = Lambda (map (uncurry VariablePattern) [v, l1])
       (Case Rigid (uncurry mkVar v)
Finn Teegen's avatar
Finn Teegen committed
909
910
          [ caseAlt p t (append e1 (uncurry mkVar l1))
          , caseAlt p (uncurry VariablePattern v) (uncurry mkVar l1)])
911

Finn Teegen's avatar
Finn Teegen committed
912
913
914
  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
915

916
917
918
919
-- -----------------------------------------------------------------------------
-- Desugaring of Lists, labels, fields, and literals
-- -----------------------------------------------------------------------------

Finn Teegen's avatar
Finn Teegen committed
920
921
dsList :: (b -> b -> b) -> b -> [b] -> b
dsList = foldr
922

Finn Teegen's avatar
Finn Teegen committed
923
924
--dsLabel :: a -> [(QualIdent, a)] -> QualIdent -> a
--dsLabel def fs l = fromMaybe def (lookup l fs)
925
926
927
928

dsField :: (a -> b -> DsM (a, b)) -> a -> Field b -> DsM (a, Field b)
dsField ds z (Field p l x) = second (Field p l) <$> (ds z x)

Finn Teegen's avatar
Finn Teegen committed
929
930
dsLiteral :: PredType -> Literal
          -> Either (Expression PredType) (Expression PredType)
Finn Teegen's avatar
Finn Teegen committed
931
932
dsLiteral pty (Char c) = Right $ Literal pty $ Char c
dsLiteral pty (Int i) = Right $ fixLiteral (unpredType pty)
Finn Teegen's avatar
Finn Teegen committed
933
934
  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
        fixLiteral ty
Finn Teegen's avatar
Finn Teegen committed
935
936
          | ty == intType = Literal pty $ Int i
          | ty == floatType = Literal pty $ Float $ fromInteger i
Finn Teegen's avatar
Finn Teegen committed
937
          | otherwise = Apply (prelFromInteger $ unpredType pty) $
Finn Teegen's avatar
Finn Teegen committed
938
939
                          Literal predIntType $ Int i
dsLiteral pty f@(Float _) = Right $ fixLiteral (unpredType pty)
Finn Teegen's avatar
Finn Teegen committed
940
941
942
943
944
  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
        fixLiteral ty
          | ty == floatType = Literal pty f
          | otherwise = Apply (prelFromRational $ unpredType pty) $
                          Literal predFloatType f
Finn Teegen's avatar
Finn Teegen committed
945
946
dsLiteral pty (String cs) =
  Left $ List pty $ map (Literal pty' . Char) cs
Finn Teegen's avatar
Finn Teegen committed
947
  where pty' = predType $ elemType $ unpredType pty
948
949

negateLiteral :: Literal -> Literal
Finn Teegen's avatar
Finn Teegen committed
950
951
negateLiteral (Int i) = Int (-i)
negateLiteral (Float f) = Float (-f)
Finn Teegen's avatar
Finn Teegen committed
952
negateLiteral _ = internalError "Desugar.negateLiteral"
953

954
955
956
957
-- ---------------------------------------------------------------------------
-- Prelude entities
-- ---------------------------------------------------------------------------

Finn Teegen's avatar
Finn Teegen committed
958
959
preludeFun :: [Type] -> Type -> String -> Expression PredType
preludeFun tys ty = Variable (predType $ foldr TypeArrow ty tys) . preludeIdent
960
961
962
963

preludeIdent :: String -> QualIdent
preludeIdent = qualifyWith preludeMIdent . mkIdent

Finn Teegen's avatar
Finn Teegen committed
964
965
prelBind :: Type -> Type -> Type -> Expression PredType
prelBind ma a mb = preludeFun [ma, TypeArrow a mb] mb ">>="
966

Finn Teegen's avatar
Finn Teegen committed
967
968
prelBind_ :: Type -> Type -> Expression PredType
prelBind_ ma mb = preludeFun [ma, mb] mb ">>"
969

Finn Teegen's avatar
Finn Teegen committed
970
971
prelFlip :: Type -> Type -> Type -> Expression PredType
prelFlip a b c = preludeFun [TypeArrow a (TypeArrow b c), b, a] c "flip"
972

Finn Teegen's avatar
Finn Teegen committed
973
974
prelFromInteger :: Type -> Expression PredType
prelFromInteger a = preludeFun [intType] a "fromInteger"
975

Finn Teegen's avatar
Finn Teegen committed
976
977
prelFromRational :: Type -> Expression PredType
prelFromRational a = preludeFun [floatType] a "fromRational"
978

Finn Teegen's avatar
Finn Teegen committed
979
980
prelEnumFrom :: Type -> Expression PredType
prelEnumFrom a = preludeFun [a] (listType a) "enumFrom"