Desugar.hs 49.6 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
10
11
12
13
14
  License     :  OtherLicense

  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)
Finn Teegen's avatar
Finn Teegen committed
75
76
import           Data.List                  ( (\\), elemIndex, nub, partition
                                            , tails )
77
import           Data.Maybe                 (fromMaybe)
78
79
80
81
82
83
84
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
85
86
87
import Base.CurryTypes
import Base.Messages      (internalError)
import Base.TypeExpansion
88
import Base.Types
Finn Teegen's avatar
Finn Teegen committed
89
import Base.TypeSubst
90
import Base.Typing
Finn Teegen's avatar
Finn Teegen committed
91
import Base.Utils (fst3)
92

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

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

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

type DsM a = S.State DesugarState a

getModuleIdent :: DsM ModuleIdent
getModuleIdent = S.gets moduleIdent

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

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

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

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

160
161
162
-- ---------------------------------------------------------------------------
-- Desugaring
-- ---------------------------------------------------------------------------
163

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

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

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

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

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

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

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

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

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

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

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

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

275
-- Desugaring of the right-hand-side of declarations
Finn Teegen's avatar
Finn Teegen committed
276
277
278
279
280
281
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
282
  where ie' = ie `mplus` Just (idName f)
Finn Teegen's avatar
Finn Teegen committed
283
284
285
dsDeclRhs fs@(FreeDecl              _ _) = return fs
dsDeclRhs _                              =
  error "Desugar.dsDeclRhs: no pattern match"
286

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

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

-- -----------------------------------------------------------------------------
-- 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
316
317
318
319
dsRhs :: Position -> (Expression PredType -> Expression PredType)
      -> Rhs PredType -> DsM (Rhs PredType)
dsRhs p f rhs =
  expandRhs (prelFailed (typeOf rhs)) f rhs >>= dsExpr p >>= return . simpleRhs p
320

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

Finn Teegen's avatar
Finn Teegen committed
335
336
337
boolGuards :: [CondExpr PredType] -> Bool
boolGuards []                    = False
boolGuards (CondExpr _ g _ : es) = not (null es) || typeOf g == boolType
338
339

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

344
345
346
347
-- -----------------------------------------------------------------------------
-- Desugaring of non-linear patterns
-- -----------------------------------------------------------------------------

348
349
350
351
-- 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.
352
-- Non-linear patterns inside single functional patterns are not desugared,
353
-- as this special case is handled later.
Finn Teegen's avatar
Finn Teegen committed
354
355
dsNonLinearity :: [Pattern PredType]
               -> DsM ([Expression PredType], [Pattern PredType])
356
357
358
359
dsNonLinearity ts = do
  ((_, cs), ts') <- mapAccumM dsNonLinear (Set.empty, []) ts
  return (reverse cs, ts')

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

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

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

-- -----------------------------------------------------------------------------
-- 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
452
453
454
dsFunctionalPatterns
  :: Position -> [Pattern PredType]
  -> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])
455
456
457
458
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
459
  let (ds, cs) = genFPExpr p (concatMap patternVars ts') (reverse bs)
460
461
462
  -- return (declarations, constraints, desugared patterns)
  return (ds, cs, ts')

Finn Teegen's avatar
Finn Teegen committed
463
type LazyBinding = (Pattern PredType, (PredType, Ident))
464

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

-- -----------------------------------------------------------------------------
544
-- Desugaring of ordinary patterns
545
-- -----------------------------------------------------------------------------
546
547
548
549
550
551
552
553

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

554
555
556
557
558
559
560
561
562
563
564
565
566
-- 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
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
dsLiteralPat :: PredType -> Literal
             -> Either (Pattern PredType) (Pattern PredType)
dsLiteralPat pty c@(Char _ _) = Right (LiteralPattern pty c)
dsLiteralPat pty (Int ref i) =
  Right (LiteralPattern pty (fixLiteral (unpredType pty)))
  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
        fixLiteral ty
          | ty == floatType = Float ref $ fromInteger i
          | otherwise = Int ref i
dsLiteralPat pty f@(Float _ _) = Right (LiteralPattern pty f)
dsLiteralPat pty (String (SrcRef [i]) cs) =
  Left $ ListPattern pty (consRefs i cs) $
    map (LiteralPattern pty') $ zipWith (Char . SrcRef . (:[])) [i, i + 2 ..] cs
  where pty' = predType $ elemType $ unpredType pty
        -- TODO: Share with 'dsLiteral'
        consRefs r []     = [SrcRef [r]]
        consRefs r (_:xs) = let r' = r + 2
                            in  r' `seq` (SrcRef [r'] : consRefs r' xs)
dsLiteralPat _ (String _ _) = internalError $
  "Desugar.dsLiteralPat: wrong source ref for string"

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)
dsPat p ds (NegativePattern   pty _ l) =
  dsPat p ds (LiteralPattern pty (negateLiteral l))
dsPat p ds (ConstructorPattern pty c [t]) = do
596
597
  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
598
599
600
601
602
  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])
603
dsPat p ds (ParenPattern           t) = dsPat p ds t
Finn Teegen's avatar
Finn Teegen committed
604
605
606
607
608
609
610
611
612
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)
613
dsPat p ds (TuplePattern      pos ts) =
Finn Teegen's avatar
Finn Teegen committed
614
615
616
  dsPat p ds (ConstructorPattern pty (addRef pos $ qTupleId $ length ts) ts)
  where pty = predType (tupleType (map typeOf ts))
dsPat p ds (ListPattern      pty pos ts) =
617
  second (dsList pos cons nil) <$> mapAccumM (dsPat p) ds ts
Finn Teegen's avatar
Finn Teegen committed
618
619
  where nil  p' = ConstructorPattern pty (addRef p' qNilId) []
        cons p' t ts' = ConstructorPattern pty (addRef p' qConsId) [t, ts']
620
621
dsPat p ds (AsPattern            v t) = dsAs p v <$> dsPat p ds t
dsPat p ds (LazyPattern          r t) = dsLazy r p ds t
Finn Teegen's avatar
Finn Teegen committed
622
dsPat p ds (FunctionPattern    pty f ts) = second (FunctionPattern pty f)
623
                                        <$> mapAccumM (dsPat p) ds ts
Finn Teegen's avatar
Finn Teegen committed
624
625
dsPat p ds (InfixFuncPattern pty t1 f t2) =
  dsPat p ds (FunctionPattern pty f [t1, t2])
626

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

Finn Teegen's avatar
Finn Teegen committed
635
636
dsLazy :: SrcRef -> Position -> [Decl PredType] -> Pattern PredType
       -> DsM ([Decl PredType], Pattern PredType)
637
dsLazy pos p ds t = case t of
Finn Teegen's avatar
Finn Teegen committed
638
  VariablePattern _ _ -> return (ds, t)
639
  ParenPattern     t' -> dsLazy pos p ds t'
640
  AsPattern      v t' -> dsAs p v <$> dsLazy pos p ds t'
641
642
  LazyPattern pos' t' -> dsLazy pos' p ds t'
  _                   -> do
Finn Teegen's avatar
Finn Teegen committed
643
644
645
646
    (pty, v'') <- freshVar "_#lazy" t
    v' <- addPositionIdent (AST pos) <$> return v''
    return ( patDecl p { astRef = pos } t (mkVar pty v') : ds
           , VariablePattern pty v' )
647

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

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

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

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

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

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

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

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

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

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

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

826
827
828
829
830
831
-- The do-notation is desugared in the following way:
--
-- `dsDo([]         , e)` -> `e`
-- `dsDo(e'     ; ss, e)` -> `e' >>        dsDo(ss, e)`
-- `dsDo(p <- e'; ss, e)` -> `e' >>= \p -> dsDo(ss, e)`
-- `dsDo(let ds ; ss, e)` -> `let ds in    dsDo(ss, e)`
Finn Teegen's avatar
Finn Teegen committed
832
dsDo :: [Statement PredType] -> Expression PredType -> Expression PredType
833
dsDo sts e = foldr dsStmt e sts
Finn Teegen's avatar
Finn Teegen committed
834
835
836
837
838
839
840

dsStmt :: Statement PredType -> Expression PredType -> Expression PredType
dsStmt (StmtExpr r   e1) e' =
  apply (prelBind_ (typeOf e1) (typeOf e') r) [e1, e']
dsStmt (StmtBind r t e1) e' =
  apply (prelBind (typeOf e1) (typeOf t) (typeOf e') r) [e1, Lambda r [t] e']
dsStmt (StmtDecl     ds) e' = Let ds e'
841

842
-- -----------------------------------------------------------------------------
843
-- Desugaring of List Comprehensions
844
845
-- -----------------------------------------------------------------------------

846
847
848
849
850
851
852
853
854
855
856
857
858
859
-- 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.
860
-- TODO: Unfortunately, this is incorrect.
861
862
863
864
865
866
867
868
869
870
871

-- 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
872
873
874
875
dsListComp :: Position -> SrcRef -> Expression PredType -> [Statement PredType]
           -> DsM (Expression PredType)
dsListComp p r e []     =
  dsExpr p (List (predType $ listType $ typeOf e) [r,r] [e])
876
877
dsListComp p r e (q:qs) = dsQual p q (ListCompr r e qs)

Finn Teegen's avatar
Finn Teegen committed
878
879
880
881
dsQual :: Position -> Statement PredType -> Expression PredType
       -> DsM (Expression PredType)
dsQual p (StmtExpr   r b) e =
  dsExpr p (IfThenElse r b e (List (predType $ typeOf e) [r] []))
882
883
dsQual p (StmtDecl    ds) e = dsExpr p (Let ds e)
dsQual p (StmtBind r t l) e
Finn Teegen's avatar
Finn Teegen committed
884
885
886
887
888
889
890
891
892
  | isVariablePattern t = dsExpr p (qualExpr t e l)
  | otherwise = do
    v <- freshVar "_#var" t
    l' <- freshVar "_#var" e
    --TODO: Add SrcRefs (old version below)
    --v   <- addRefId r <$> freshVar "_#var" t
    --l'  <- addRefId r <$> freshVar "_#var" e
    dsExpr p (apply (prelFoldr (typeOf t) (elemType $ typeOf l) r)
      [foldFunct v l' e, List (predType $ elemType $ typeOf l) [r] [], l])
893
  where
Finn Teegen's avatar
Finn Teegen committed
894
895
896
897
  qualExpr v (ListCompr _ e1 []) l1
    = apply (prelMap (typeOf v) (typeOf e1) r) [Lambda r [v] e1, l1]
  qualExpr v e1                  l1
    = apply (prelConcatMap (typeOf v) (elemType $ typeOf e1) r) [Lambda r [v] e1, l1]
898
  foldFunct v l1 e1
Finn Teegen's avatar
Finn Teegen committed
899
900
901
902
    = Lambda r (map (uncurry VariablePattern) [v, l1])
       (Case r Rigid (uncurry mkVar v)
          [ caseAlt p t (append e1 (uncurry mkVar l1))
          , caseAlt p (uncurry VariablePattern v) (uncurry mkVar l1)])
903

Finn Teegen's avatar
Finn Teegen committed
904
905
906
  append (ListCompr _ e1 []) l1 = apply (prelCons (typeOf e1)) [e1, l1]
  append e1                  l1 = apply (prelAppend (elemType $ typeOf e1) r) [e1, l1]
  prelCons ty                   = Constructor (predType $ consType ty) $ addRef r $ qConsId
907

908
909
910
911
912
-- -----------------------------------------------------------------------------
-- Desugaring of Lists, labels, fields, and literals
-- -----------------------------------------------------------------------------

dsList :: [SrcRef] -> (SrcRef -> b -> b -> b) -> (SrcRef -> b) -> [b] -> b
Finn Teegen's avatar
Finn Teegen committed
913
914
915
916
917
918
--TODO: Fix SrcRefs here (old version below)
dsList pos cons nil xs = foldr cons' nil' xs
  where rNil : _   = reverse pos
        nil'       = nil rNil
        cons' t ts = cons rNil t ts
{-dsList pos cons nil xs = snd (foldr cons' nil' xs)
919
920
921
  where rNil : rCs = reverse pos
        nil'                 = (rCs , nil rNil)
        cons' t (rC:rCs',ts) = (rCs', cons rC t ts)
Finn Teegen's avatar
Finn Teegen committed
922
        cons' _ ([],_) = error "Desugar.dsList.cons': empty list"-}
923

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

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
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
dsLiteral :: PredType -> Literal
          -> Either (Expression PredType) (Expression PredType)
dsLiteral pty (Char ref c) = Right $ Literal pty $ Char ref c
dsLiteral pty (Int ref i) = Right $ fixLiteral (unpredType pty)
  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
        fixLiteral ty
          | ty == intType = Literal pty $ Int ref i
          | ty == floatType = Literal pty $ Float ref $ fromInteger i
          | otherwise = Apply (prelFromInteger $ unpredType pty) $
                          Literal predIntType $ Int ref i
dsLiteral pty f@(Float _ _) = Right $ fixLiteral (unpredType pty)
  where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys)
        fixLiteral ty
          | ty == floatType = Literal pty f
          | otherwise = Apply (prelFromRational $ unpredType pty) $
                          Literal predFloatType f
dsLiteral pty (String (SrcRef [i]) cs) =
  Left $ List pty (consRefs i cs) $
    map (Literal pty') $ zipWith (Char . SrcRef . (:[])) [i, i + 2 ..] cs
  where pty' = predType $ elemType $ unpredType pty
        -- TODO: Share with 'dsLiteralPat'
        consRefs r []     = [SrcRef [r]]
952
953
        consRefs r (_:xs) = let r' = r + 2
                            in  r' `seq` (SrcRef [r'] : consRefs r' xs)
Finn Teegen's avatar
Finn Teegen committed
954
955
dsLiteral _ (String _ _) = internalError $
  "Desugar.dsLiteral: wrong source ref for string"
956
957

negateLiteral :: Literal -> Literal
Finn Teegen's avatar
Finn Teegen committed
958
959
960
negateLiteral (Int ref i) = Int ref (-i)
negateLiteral (Float ref f) = Float ref (-f)
negateLiteral _ = internalError "Desugar.negateLiteral"
961

962
963
964
965
-- ---------------------------------------------------------------------------
-- Prelude entities
-- ---------------------------------------------------------------------------

Finn Teegen's avatar
Finn Teegen committed
966
967
968
prel :: [Type] -> Type -> String -> SrcRef -> Expression PredType
prel tys ty s r =
  Variable (predType $ foldr TypeArrow ty tys) $ addRef r $ preludeIdent s
969

Finn Teegen's avatar
Finn Teegen committed
970
971
preludeFun :: [Type] -> Type -> String -> Expression PredType
preludeFun tys ty = Variable (predType $ foldr TypeArrow ty tys) . preludeIdent
972
973
974
975

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

Finn Teegen's avatar
Finn Teegen committed
976
977
prelBind :: Type -> Type -> Type -> SrcRef -> Expression PredType
prelBind ma a mb = prel [ma, TypeArrow a mb] mb ">>="
978

Finn Teegen's avatar
Finn Teegen committed
979
980
prelBind_ :: Type -> Type -> SrcRef -> Expression PredType
prelBind_ ma mb = prel [ma, mb] mb ">>"
981

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

Finn Teegen's avatar
Finn Teegen committed
985
986
prelFromInteger :: Type -> Expression PredType
prelFromInteger a = preludeFun [intType] a "fromInteger"
987

Finn Teegen's avatar
Finn Teegen committed
988
989
prelFromRational :: Type -> Expression PredType
prelFromRational a = preludeFun [floatType] a "fromRational"
990

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

Finn Teegen's avatar
Finn Teegen committed
994
995
prelEnumFromTo :: Type -> Expression PredType
prelEnumFromTo a = preludeFun [a, a] (listType a) "enumFromTo"
996

Finn Teegen's avatar
Finn Teegen committed
997
998
prelEnumFromThen :: Type -> Expression PredType
prelEnumFromThen a = preludeFun [a, a] (listType a) "enumFromThen"
999

Finn Teegen's avatar
Finn Teegen committed
1000
1001
prelEnumFromThenTo :: Type -> Expression PredType
prelEnumFromThenTo a = preludeFun [a, a, a] (listType a) "enumFromThenTo"
1002

Finn Teegen's avatar
Finn Teegen committed
1003
1004
prelNegate :: Type -> Expression PredType
prelNegate a = preludeFun [a] a "negate"
1005

Finn Teegen's avatar
Finn Teegen committed
1006
1007
prelFailed :: Type -> Expression PredType
prelFailed a = preludeFun [] a "failed"
1008

Finn Teegen's avatar
Finn Teegen committed
1009
1010
prelUnknown :: Type -> Expression PredType
prelUnknown a = preludeFun [] a "unknown"
1011

Finn Teegen's avatar
Finn Teegen committed
1012
1013
prelMap :: Type -> Type -> SrcRef -> Expression PredType
prelMap a b = prel [TypeArrow a b, listType a] (listType b) "map"
1014

Finn Teegen's avatar
Finn Teegen committed
1015
1016
prelFoldr :: Type -> Type -> SrcRef -> Expression PredType
prelFoldr a b = prel [TypeArrow a (TypeArrow b b), b, listType a] b "foldr"
1017

Finn Teegen's avatar
Finn Teegen committed
1018
1019
prelAppend :: Type -> SrcRef -> Expression PredType
prelAppend a = prel [listType a, listType a] (listType a) "++"
1020

Finn Teegen's avatar
Finn Teegen committed
1021
1022
1023
prelConcatMap :: Type -> Type -> SrcRef -> Expression PredType
prelConcatMap a b =
  prel [TypeArrow a (listType b), listType a] (listType b) "concatMap"
1024

Finn Teegen's avatar
Finn Teegen committed
1025
1026
(=:<=) :: Expression PredType -> Expression PredType -> Expression PredType
e1 =:<= e2 = apply (preludeFun [typeOf e1, typeOf e2] boolType "=:<=") [e1, e2]
1027

Finn Teegen's avatar
Finn Teegen committed
1028
1029
(=:=) :: Expression PredType -> Expression PredType -> Expression PredType
e1 =:= e2 = apply (preludeFun [typeOf e1, typeOf e2] boolType "=:=") [e1, e2]
1030

Finn Teegen's avatar
Finn Teegen committed
1031
1032
(&>) :: Expression PredType -> Expression PredType -> Expression PredType
e1 &> e2 = apply (preludeFun [boolType, typeOf e2] (typeOf e2) "cond") [e1, e2]
1033

Finn Teegen's avatar
Finn Teegen committed
1034
1035
(&) :: Expression PredType -> Expression PredType -> Expression PredType
e1 & e2 = apply (preludeFun [boolType, boolType] boolType "&") [e1, e2]
1036

Finn Teegen's avatar
Finn Teegen committed
1037
1038
1039
1040
1041
truePat :: Pattern PredType
truePat = ConstructorPattern predBoolType qTrueId []

falsePat :: Pattern PredType
falsePat = ConstructorPattern predBoolType qFalseId []
1042
1043
1044
1045
1046

-- ---------------------------------------------------------------------------
-- Auxiliary definitions
-- ---------------------------------------------------------------------------

1047
isNewtypeConstr :: QualIdent -> DsM Bool
Finn Teegen's avatar
Finn Teegen committed
1048
1049
isNewtypeConstr c = getValueEnv >>= \vEnv -> return $
  case qualLookupValue c vEnv of
1050
1051
    [NewtypeConstructor _ _ _] -> True
    [DataConstructor  _ _ _ _] -> False
Finn Teegen's avatar
Finn Teegen committed
1052
    x -> internalError $ "Desugar.isNewtypeConstr: " ++ show c ++ " is " ++ show x
1053

Finn Teegen's avatar
Finn Teegen committed
1054
1055
1056
1057
1058
conType :: QualIdent -> ValueEnv -> ([Ident], ExistTypeScheme)
conType c vEnv = case qualLookupValue c vEnv of
  [DataConstructor _ _ ls ty] -> (ls , ty)
  [NewtypeConstructor _ l ty] -> ([l], ty)
  _                           -> internalError $ "Desguar.conType: " ++ show c
1059

Finn Teegen's avatar
Finn Teegen committed
1060
1061
1062
1063
1064
varType :: QualIdent -> ValueEnv -> TypeScheme
varType v vEnv = case qualLookupValue v vEnv of
  Value _ _ _ tySc : _ -> tySc
  Label _ _   tySc : _ ->