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
64
import           Control.Monad.Extra        (concatMapM)
import           Control.Monad.ListM        (mapAccumM)
65
import qualified Control.Monad.State as S   (State, runState, gets, modify)
66
import           Data.Foldable              (foldrM)
Finn Teegen's avatar
Finn Teegen committed
67
68
import           Data.List                  ( (\\), elemIndex, nub, partition
                                            , tails )
69
import           Data.Maybe                 (fromMaybe)
70
71
72
73
74
75
76
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
77
import Base.CurryTypes
78
import Base.Messages (internalError)
Finn Teegen's avatar
Finn Teegen committed
79
import Base.TypeExpansion
80
import Base.Types
Finn Teegen's avatar
Finn Teegen committed
81
import Base.TypeSubst
82
import Base.Typing
Finn Teegen's avatar
Finn Teegen committed
83
import Base.Utils (fst3)
84

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

88
89
90
91
-- 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
92
-- Since they cannot occur in local declaration groups, they are filtered
93
94
95
-- 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
96
97
98
desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module PredType
        -> (Module PredType, ValueEnv)
desugar xs vEnv tcEnv (Module ps m es is ds)
99
100
  = (Module ps m es is ds', valueEnv s')
  where (ds', s') = S.runState (desugarModuleDecls ds)
Finn Teegen's avatar
Finn Teegen committed
101
                               (DesugarState m xs tcEnv vEnv 1)
102
103
104
105
106
107
108
109
110

-- ---------------------------------------------------------------------------
-- 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
111
112
113
114
115
116
117
-- 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
118
119
  , valueEnv    :: ValueEnv         -- will be extended
  , nextId      :: Integer          -- counter
120
121
122
123
124
125
126
  }

type DsM a = S.State DesugarState a

getModuleIdent :: DsM ModuleIdent
getModuleIdent = S.gets moduleIdent

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

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
139
  S.modify $ \s -> s { nextId = succ nid }
140
141
142
143
144
145
  return nid

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

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

152
153
154
-- ---------------------------------------------------------------------------
-- Desugaring
-- ---------------------------------------------------------------------------
155

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

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

175
176
177
178
179
180
181
182
183
-- -----------------------------------------------------------------------------
-- 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.
184

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

-- Generate a selector function for a single record label
Finn Teegen's avatar
Finn Teegen committed
201
202
203
204
205
206
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
207
208
209

-- 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
210
genSelEqn :: Position -> Ident -> QualIdent -> DsM [Equation PredType]
211
genSelEqn p l qc = do
Finn Teegen's avatar
Finn Teegen committed
212
213
214
  vEnv <- getValueEnv
  let (ls, ty) = conType qc vEnv
      (tys, ty0) = arrowUnapply (instType ty)
215
  case elemIndex l ls of
Finn Teegen's avatar
Finn Teegen committed
216
217
218
219
    Just n  -> do
      vs <- mapM (freshVar "_#rec") tys
      let pat = constrPattern (predType ty0) qc vs
      return [mkEquation p l [pat] (uncurry mkVar (vs !! n))]
220
221
222
223
    Nothing -> return []

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

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

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

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

251
-- TODO: Check if obsolete and remove
252
253
254
255
256
257
258
259
260
-- 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.

261
-- Desugaring of the right-hand-side of declarations
Finn Teegen's avatar
Finn Teegen committed
262
dsDeclRhs :: Decl PredType -> DsM (Decl PredType)
Finn Teegen's avatar
Finn Teegen committed
263
dsDeclRhs (FunctionDecl p pty f eqs) =
Finn Teegen's avatar
Finn Teegen committed
264
  FunctionDecl p pty f <$> mapM dsEquation eqs
Finn Teegen's avatar
Finn Teegen committed
265
266
267
268
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
269
  error "Desugar.dsDeclRhs: no pattern match"
270

271
-- Desugaring of an equation
Finn Teegen's avatar
Finn Teegen committed
272
dsEquation :: Equation PredType -> DsM (Equation PredType)
273
dsEquation (Equation p lhs rhs) = do
274
275
276
277
278
279
  (     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'
280
281
  where (f, ts) = flatLhs lhs

282
283
284
-- 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
285
constrain :: [Expression PredType] -> Expression PredType -> Expression PredType
286
constrain cs e = if null cs then e else foldr1 (&) cs &> e
287
288
289
290
291
292
293
294
295
296
297
298
299

-- -----------------------------------------------------------------------------
-- 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
300
301
dsRhs :: Position -> (Expression PredType -> Expression PredType)
      -> Rhs PredType -> DsM (Rhs PredType)
302
dsRhs p f rhs =     expandRhs (prelFailed (typeOf rhs)) f rhs
303
304
305
306
                >>= dsExpr pRhs
                >>= return . simpleRhs pRhs
  where
  pRhs = fromMaybe p (getRhsPosition rhs)
307

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

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

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

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

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

339
340
341
342
-- 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.
343
-- Non-linear patterns inside single functional patterns are not desugared,
344
-- as this special case is handled later.
Finn Teegen's avatar
Finn Teegen committed
345
346
dsNonLinearity :: [Pattern PredType]
               -> DsM ([Expression PredType], [Pattern PredType])
347
348
349
350
dsNonLinearity ts = do
  ((_, cs), ts') <- mapAccumM dsNonLinear (Set.empty, []) ts
  return (reverse cs, ts')

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

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

Finn Teegen's avatar
Finn Teegen committed
388
389
dsNonLinearFuncPat :: NonLinearEnv -> Pattern PredType
                   -> DsM (NonLinearEnv, Pattern PredType)
390
dsNonLinearFuncPat (vis, eqs) fp = do
Finn Teegen's avatar
Finn Teegen committed
391
392
393
394
395
396
397
398
399
400
401
402
  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
403
substPat _ n@(NegativePattern       _ _) = n
Finn Teegen's avatar
Finn Teegen committed
404
405
406
407
408
409
410
411
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)
412
  where substField (Field pos l pat) = Field pos l (substPat s pat)
Finn Teegen's avatar
Finn Teegen committed
413
substPat s (TuplePattern             ps) = TuplePattern
Finn Teegen's avatar
Finn Teegen committed
414
                                         $ map (substPat s) ps
Finn Teegen's avatar
Finn Teegen committed
415
substPat s (ListPattern            a ps) = ListPattern a
Finn Teegen's avatar
Finn Teegen committed
416
417
418
                                         $ 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
419
substPat s (LazyPattern               p) = LazyPattern (substPat s p)
Finn Teegen's avatar
Finn Teegen committed
420
421
422
423
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)
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442

-- -----------------------------------------------------------------------------
-- 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
443
444
445
dsFunctionalPatterns
  :: Position -> [Pattern PredType]
  -> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])
446
447
448
449
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
450
  let (ds, cs) = genFPExpr p (concatMap patternVars ts') (reverse bs)
451
452
453
  -- return (declarations, constraints, desugared patterns)
  return (ds, cs, ts')

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

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

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

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

547
548
549
550
551
552
553
554
555
556
557
558
559
-- 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
560
561
dsLiteralPat :: PredType -> Literal
             -> Either (Pattern PredType) (Pattern PredType)
Finn Teegen's avatar
Finn Teegen committed
562
563
dsLiteralPat pty c@(Char _) = Right (LiteralPattern pty c)
dsLiteralPat pty (Int i) =
Finn Teegen's avatar
Finn Teegen committed
564
565
566
  Right (LiteralPattern pty (fixLiteral (unpredType pty)))
  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
        fixLiteral ty
Finn Teegen's avatar
Finn Teegen committed
567
568
569
570
571
          | 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
572
573
574
575
576
577
578
  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
579
dsPat p ds (NegativePattern     pty l) =
Finn Teegen's avatar
Finn Teegen committed
580
581
582
583
584
  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])
585
dsPat p ds (ParenPattern           t) = dsPat p ds t
Finn Teegen's avatar
Finn Teegen committed
586
587
588
589
590
591
592
593
594
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
595
596
dsPat p ds (TuplePattern          ts) =
  dsPat p ds (ConstructorPattern pty (qTupleId $ length ts) ts)
Finn Teegen's avatar
Finn Teegen committed
597
  where pty = predType (tupleType (map typeOf ts))
Finn Teegen's avatar
Finn Teegen committed
598
599
600
601
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']
602
dsPat p ds (AsPattern            v t) = dsAs p v <$> dsPat p ds t
Finn Teegen's avatar
Finn Teegen committed
603
dsPat p ds (LazyPattern            t) = dsLazy p ds t
Finn Teegen's avatar
Finn Teegen committed
604
dsPat p ds (FunctionPattern    pty f ts) = second (FunctionPattern pty f)
605
                                        <$> mapAccumM (dsPat p) ds ts
Finn Teegen's avatar
Finn Teegen committed
606
607
dsPat p ds (InfixFuncPattern pty t1 f t2) =
  dsPat p ds (FunctionPattern pty f [t1, t2])
608

Finn Teegen's avatar
Finn Teegen committed
609
610
dsAs :: Position -> Ident -> ([Decl PredType], Pattern PredType)
     -> ([Decl PredType], Pattern PredType)
611
dsAs p v (ds, t) = case t of
Finn Teegen's avatar
Finn Teegen committed
612
613
614
615
  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)
616

Finn Teegen's avatar
Finn Teegen committed
617
dsLazy :: Position -> [Decl PredType] -> Pattern PredType
Finn Teegen's avatar
Finn Teegen committed
618
       -> DsM ([Decl PredType], Pattern PredType)
Finn Teegen's avatar
Finn Teegen committed
619
dsLazy p ds t = case t of
Finn Teegen's avatar
Finn Teegen committed
620
  VariablePattern _ _ -> return (ds, t)
Finn Teegen's avatar
Finn Teegen committed
621
622
623
624
625
626
  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')
627

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

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

Finn Teegen's avatar
Finn Teegen committed
731
732
733
734
735
736
737
738
-- 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

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

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

749
750
751
752
753
754
755
756
-- 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
757
758
759
dsCase :: Position -> CaseType -> Expression PredType -> [Alt PredType]
       -> DsM (Expression PredType)
dsCase p ct e alts
Finn Teegen's avatar
Finn Teegen committed
760
  | null alts = internalError "Desugar.dsCase: empty list of alternatives"
761
762
763
  | otherwise = do
    m  <- getModuleIdent
    e' <- dsExpr p e
Finn Teegen's avatar
Finn Teegen committed
764
    v  <- freshVar "_#case" e
765
766
767
768
    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
769
  mkCase m (pty, v) e' bs
Finn Teegen's avatar
Finn Teegen committed
770
771
    | v `elem` qfv m bs = Let [varDecl p pty v e'] (Case ct (mkVar pty v) bs)
    | otherwise         = Case ct e' bs
772

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

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

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

Finn Teegen's avatar
Finn Teegen committed
791
792
793
794
795
796
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)
797
  = and ((c1 == c2) : zipWith isCompatible ts1 ts2)
Finn Teegen's avatar
Finn Teegen committed
798
799
isCompatible (LiteralPattern _ l1) (LiteralPattern _ l2) = l1 == l2
isCompatible _ _ = False
800

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

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

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

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

837
838
839
840
841
842
843
844
845
846
847
848
849
850
-- 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.
851
-- TODO: Unfortunately, this is incorrect.
852
853
854
855
856
857
858
859
860
861
862

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

Finn Teegen's avatar
Finn Teegen committed
869
870
dsQual :: Position -> Statement PredType -> Expression PredType
       -> DsM (Expression PredType)
Finn Teegen's avatar
Finn Teegen committed
871
872
873
874
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
875
876
877
878
  | 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
879
880
    dsExpr p (apply (prelFoldr (typeOf t) (typeOf e))
      [foldFunct v l' e, List (predType $ typeOf e) [], l])
881
  where
Finn Teegen's avatar
Finn Teegen committed
882
883
  qualExpr v (ListCompr e1 []) l1
    = apply (prelMap (typeOf v) (typeOf e1)) [Lambda [v] e1, l1]
Finn Teegen's avatar
Finn Teegen committed
884
  qualExpr v e1                  l1
Finn Teegen's avatar
Finn Teegen committed
885
    = apply (prelConcatMap (typeOf v) (elemType $ typeOf e1)) [Lambda [v] e1, l1]
886
  foldFunct v l1 e1
Finn Teegen's avatar
Finn Teegen committed
887
888
    = Lambda (map (uncurry VariablePattern) [v, l1])
       (Case Rigid (uncurry mkVar v)
Finn Teegen's avatar
Finn Teegen committed
889
890
          [ caseAlt p t (append e1 (uncurry mkVar l1))
          , caseAlt p (uncurry VariablePattern v) (uncurry mkVar l1)])
891

Finn Teegen's avatar
Finn Teegen committed
892
893
894
  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
895

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

Finn Teegen's avatar
Finn Teegen committed
900
901
dsList :: (b -> b -> b) -> b -> [b] -> b
dsList = foldr
902

Finn Teegen's avatar
Finn Teegen committed
903
904
--dsLabel :: a -> [(QualIdent, a)] -> QualIdent -> a
--dsLabel def fs l = fromMaybe def (lookup l fs)
905
906
907
908

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
909
910
dsLiteral :: PredType -> Literal
          -> Either (Expression PredType) (Expression PredType)
Finn Teegen's avatar
Finn Teegen committed
911
912
dsLiteral pty (Char c) = Right $ Literal pty $ Char c
dsLiteral pty (Int i) = Right $ fixLiteral (unpredType pty)
Finn Teegen's avatar
Finn Teegen committed
913
914
  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
        fixLiteral ty
Finn Teegen's avatar
Finn Teegen committed
915
916
          | ty == intType = Literal pty $ Int i
          | ty == floatType = Literal pty $ Float $ fromInteger i
Finn Teegen's avatar
Finn Teegen committed
917
          | otherwise = Apply (prelFromInteger $ unpredType pty) $
Finn Teegen's avatar
Finn Teegen committed
918
919
                          Literal predIntType $ Int i
dsLiteral pty f@(Float _) = Right $ fixLiteral (unpredType pty)
Finn Teegen's avatar
Finn Teegen committed
920
921
922
923
924
  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
925
926
dsLiteral pty (String cs) =
  Left $ List pty $ map (Literal pty' . Char) cs
Finn Teegen's avatar
Finn Teegen committed
927
  where pty' = predType $ elemType $ unpredType pty
928
929

negateLiteral :: Literal -> Literal
Finn Teegen's avatar
Finn Teegen committed
930
931
negateLiteral (Int i) = Int (-i)
negateLiteral (Float f) = Float (-f)
Finn Teegen's avatar
Finn Teegen committed
932
negateLiteral _ = internalError "Desugar.negateLiteral"
933

934
935
936
937
-- ---------------------------------------------------------------------------
-- Prelude entities
-- ---------------------------------------------------------------------------

Finn Teegen's avatar
Finn Teegen committed
938
939
preludeFun :: [Type] -> Type -> String -> Expression PredType
preludeFun tys ty = Variable (predType $ foldr TypeArrow ty tys) . preludeIdent
940
941
942
943

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

Finn Teegen's avatar
Finn Teegen committed
944
945
prelBind :: Type -> Type -> Type -> Expression PredType
prelBind ma a mb = preludeFun [ma, TypeArrow a mb] mb ">>="
946

Finn Teegen's avatar
Finn Teegen committed
947
948
prelBind_ :: Type -> Type -> Expression PredType
prelBind_ ma mb = preludeFun [ma, mb] mb ">>"
949

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

Finn Teegen's avatar
Finn Teegen committed
953
954
prelFromInteger :: Type -> Expression PredType
prelFromInteger a = preludeFun [intType] a "fromInteger"
955

Finn Teegen's avatar
Finn Teegen committed
956
957
prelFromRational :: Type -> Expression PredType
prelFromRational a = preludeFun [floatType] a "fromRational"
958

Finn Teegen's avatar
Finn Teegen committed
959
960
prelEnumFrom :: Type -> Expression PredType
prelEnumFrom a = preludeFun [a] (listType a) "enumFrom"
Jan Rasmus Tikovsky 's avatar