{- |
  Module      :  $Header$
  Description :  Desugaring Curry Expressions
  Copyright   :  (c) 2001 - 2004 Wolfgang Lux
                                 Martin Engelke
                     2011 - 2015 Björn Peemöller
                     2015        Jan Tikovsky
                     2016 - 2017 Finn Teegen
  License     :  BSD-3-clause

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

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

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

  * Patterns in equations and case alternatives are composed only of
    - literals,
    - variables,
    - constructor applications, and
    - as patterns applied to literals or constructor applications.

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

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

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

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

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative        ((<$>), (<*>))
#endif
import           Control.Arrow              (first, second)
import           Control.Monad              (liftM2)
import           Control.Monad.Extra        (concatMapM)
import qualified Control.Monad.State as S   (State, runState, gets, modify)
import           Data.Foldable              (foldrM)
import           Data.List                  ( (\\), elemIndex, nub, partition
                                            , tails )
import           Data.Maybe                 (fromMaybe)
import qualified Data.Set            as Set (Set, empty, member, insert)

import Curry.Base.Ident
import Curry.Base.SpanInfo
import Curry.Syntax

import Base.Expr
import Base.CurryTypes
import Base.Messages (internalError)
import Base.TypeExpansion
import Base.Types
import Base.TypeSubst
import Base.Typing
import Base.Utils (fst3, mapAccumM)

import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTypeInfo)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)

-- TODO: some types keep their spanInfo, some don't. Probably none of them are needed

-- 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.
-- Since they cannot occur in local declaration groups, they are filtered
-- out separately. Actually, the transformation is slightly more general than
-- necessary as it allows value declarations at the top-level of a module.

desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module PredType
        -> (Module PredType, ValueEnv)
desugar :: [KnownExtension]
-> ValueEnv
-> TCEnv
-> Module PredType
-> (Module PredType, ValueEnv)
desugar xs :: [KnownExtension]
xs vEnv :: ValueEnv
vEnv tcEnv :: TCEnv
tcEnv (Module spi :: SpanInfo
spi li :: LayoutInfo
li ps :: [ModulePragma]
ps m :: ModuleIdent
m es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl PredType]
ds)
  = (SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl PredType]
-> Module PredType
forall a.
SpanInfo
-> LayoutInfo
-> [ModulePragma]
-> ModuleIdent
-> Maybe ExportSpec
-> [ImportDecl]
-> [Decl a]
-> Module a
Module SpanInfo
spi LayoutInfo
li [ModulePragma]
ps ModuleIdent
m Maybe ExportSpec
es [ImportDecl]
is [Decl PredType]
ds', DesugarState -> ValueEnv
valueEnv DesugarState
s')
  where (ds' :: [Decl PredType]
ds', s' :: DesugarState
s') = State DesugarState [Decl PredType]
-> DesugarState -> ([Decl PredType], DesugarState)
forall s a. State s a -> s -> (a, s)
S.runState ([Decl PredType] -> State DesugarState [Decl PredType]
desugarModuleDecls [Decl PredType]
ds)
                               (ModuleIdent
-> [KnownExtension] -> TCEnv -> ValueEnv -> Integer -> DesugarState
DesugarState ModuleIdent
m [KnownExtension]
xs TCEnv
tcEnv ValueEnv
vEnv 1)

-- ---------------------------------------------------------------------------
-- 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
-- type environment, which must be augmented with the types of these new
-- variables.

data DesugarState = DesugarState
  { DesugarState -> ModuleIdent
moduleIdent :: ModuleIdent      -- read-only
  , DesugarState -> [KnownExtension]
extensions  :: [KnownExtension] -- read-only
  , DesugarState -> TCEnv
tyConsEnv   :: TCEnv            -- read-only
  , DesugarState -> ValueEnv
valueEnv    :: ValueEnv         -- will be extended
  , DesugarState -> Integer
nextId      :: Integer          -- counter
  }

type DsM a = S.State DesugarState a

getModuleIdent :: DsM ModuleIdent
getModuleIdent :: DsM ModuleIdent
getModuleIdent = (DesugarState -> ModuleIdent) -> DsM ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DesugarState -> ModuleIdent
moduleIdent

checkNegativeLitsExtension :: DsM Bool
checkNegativeLitsExtension :: DsM Bool
checkNegativeLitsExtension = (DesugarState -> Bool) -> DsM Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets (\s :: DesugarState
s -> KnownExtension
NegativeLiterals KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DesugarState -> [KnownExtension]
extensions DesugarState
s)

getTyConsEnv :: DsM TCEnv
getTyConsEnv :: DsM TCEnv
getTyConsEnv = (DesugarState -> TCEnv) -> DsM TCEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DesugarState -> TCEnv
tyConsEnv

getValueEnv :: DsM ValueEnv
getValueEnv :: DsM ValueEnv
getValueEnv = (DesugarState -> ValueEnv) -> DsM ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DesugarState -> ValueEnv
valueEnv

getNextId :: DsM Integer
getNextId :: DsM Integer
getNextId = do
  Integer
nid <- (DesugarState -> Integer) -> DsM Integer
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets DesugarState -> Integer
nextId
  (DesugarState -> DesugarState) -> StateT DesugarState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((DesugarState -> DesugarState) -> StateT DesugarState Identity ())
-> (DesugarState -> DesugarState)
-> StateT DesugarState Identity ()
forall a b. (a -> b) -> a -> b
$ \s :: DesugarState
s -> DesugarState
s { nextId :: Integer
nextId = Integer -> Integer
forall a. Enum a => a -> a
succ Integer
nid }
  Integer -> DsM Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
nid

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

-- Create a fresh variable ident for a given prefix with a monomorphic type
freshVar :: Typeable t => String -> t -> DsM (PredType, Ident)
freshVar :: String -> t -> DsM (PredType, Ident)
freshVar prefix :: String
prefix t :: t
t = do
  Ident
v <- (String -> Ident
mkIdent (String -> Ident) -> (Integer -> String) -> Integer -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Integer -> String) -> Integer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show) (Integer -> Ident)
-> DsM Integer -> StateT DesugarState Identity Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DsM Integer
getNextId
  (PredType, Ident) -> DsM (PredType, Ident)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ t -> Type
forall a. Typeable a => a -> Type
typeOf t
t, Ident
v)

-- ---------------------------------------------------------------------------
-- Desugaring
-- ---------------------------------------------------------------------------

desugarModuleDecls :: [Decl PredType] -> DsM [Decl PredType]
desugarModuleDecls :: [Decl PredType] -> State DesugarState [Decl PredType]
desugarModuleDecls ds :: [Decl PredType]
ds = do
  [Decl PredType]
ds'    <- (Decl PredType -> State DesugarState [Decl PredType])
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl PredType -> State DesugarState [Decl PredType]
dsRecordDecl [Decl PredType]
ds
  [Decl PredType]
ds''   <- (Decl PredType -> State DesugarState [Decl PredType])
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl PredType -> State DesugarState [Decl PredType]
dsTypeDecl [Decl PredType]
ds'
  [Decl PredType]
ds'''  <- (Decl PredType -> StateT DesugarState Identity (Decl PredType))
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PredType -> StateT DesugarState Identity (Decl PredType)
dsClassAndInstanceDecl [Decl PredType]
ds''
  [Decl PredType]
ds'''' <- [Decl PredType] -> State DesugarState [Decl PredType]
dsDeclGroup [Decl PredType]
ds'''
  [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType] -> State DesugarState [Decl PredType])
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall a b. (a -> b) -> a -> b
$ (Decl PredType -> Bool) -> [Decl PredType] -> [Decl PredType]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Decl PredType -> Bool) -> Decl PredType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool -> Bool)
-> (Decl PredType -> Bool)
-> (Decl PredType -> Bool)
-> Decl PredType
-> Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(||) Decl PredType -> Bool
forall a. Decl a -> Bool
isValueDecl Decl PredType -> Bool
forall a. Decl a -> Bool
isTypeSig) [Decl PredType]
ds''' [Decl PredType] -> [Decl PredType] -> [Decl PredType]
forall a. [a] -> [a] -> [a]
++ [Decl PredType]
ds''''

-- -----------------------------------------------------------------------------
-- Desugaring of type declarations
-- -----------------------------------------------------------------------------

dsTypeDecl :: Decl PredType -> DsM [Decl PredType]
dsTypeDecl :: Decl PredType -> State DesugarState [Decl PredType]
dsTypeDecl (DataDecl si :: SpanInfo
si tc :: Ident
tc tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs clss :: [QualIdent]
clss) = do
  [ConstrDecl]
cs' <- (ConstrDecl -> StateT DesugarState Identity ConstrDecl)
-> [ConstrDecl] -> StateT DesugarState Identity [ConstrDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstrDecl -> StateT DesugarState Identity ConstrDecl
dsConstrDecl [ConstrDecl]
cs
  [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType] -> State DesugarState [Decl PredType])
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall a b. (a -> b) -> a -> b
$ [SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl PredType
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl a
DataDecl SpanInfo
si Ident
tc [Ident]
tvs [ConstrDecl]
cs' [QualIdent]
clss]
dsTypeDecl (NewtypeDecl si :: SpanInfo
si tc :: Ident
tc tvs :: [Ident]
tvs nc :: NewConstrDecl
nc clss :: [QualIdent]
clss) = do
  NewConstrDecl
nc' <- NewConstrDecl -> DsM NewConstrDecl
dsNewConstrDecl NewConstrDecl
nc
  [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType] -> State DesugarState [Decl PredType])
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall a b. (a -> b) -> a -> b
$ [SpanInfo
-> Ident
-> [Ident]
-> NewConstrDecl
-> [QualIdent]
-> Decl PredType
forall a.
SpanInfo
-> Ident -> [Ident] -> NewConstrDecl -> [QualIdent] -> Decl a
NewtypeDecl SpanInfo
si Ident
tc [Ident]
tvs NewConstrDecl
nc' [QualIdent]
clss]
dsTypeDecl (TypeDecl _ _ _ _) = [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return []
dsTypeDecl d :: Decl PredType
d = [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PredType
d]

dsConstrDecl :: ConstrDecl -> DsM ConstrDecl
dsConstrDecl :: ConstrDecl -> StateT DesugarState Identity ConstrDecl
dsConstrDecl (ConstrDecl si :: SpanInfo
si c :: Ident
c tys :: [TypeExpr]
tys) = SpanInfo -> Ident -> [TypeExpr] -> ConstrDecl
ConstrDecl SpanInfo
si Ident
c ([TypeExpr] -> ConstrDecl)
-> StateT DesugarState Identity [TypeExpr]
-> StateT DesugarState Identity ConstrDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeExpr -> StateT DesugarState Identity TypeExpr)
-> [TypeExpr] -> StateT DesugarState Identity [TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeExpr -> StateT DesugarState Identity TypeExpr
dsTypeExpr [TypeExpr]
tys
dsConstrDecl (ConOpDecl si :: SpanInfo
si ty1 :: TypeExpr
ty1 op :: Ident
op ty2 :: TypeExpr
ty2) =
  SpanInfo -> Ident -> [TypeExpr] -> ConstrDecl
ConstrDecl SpanInfo
si Ident
op ([TypeExpr] -> ConstrDecl)
-> StateT DesugarState Identity [TypeExpr]
-> StateT DesugarState Identity ConstrDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeExpr -> StateT DesugarState Identity TypeExpr)
-> [TypeExpr] -> StateT DesugarState Identity [TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeExpr -> StateT DesugarState Identity TypeExpr
dsTypeExpr [TypeExpr
ty1, TypeExpr
ty2]
dsConstrDecl cd :: ConstrDecl
cd = String -> StateT DesugarState Identity ConstrDecl
forall a. String -> a
internalError (String -> StateT DesugarState Identity ConstrDecl)
-> String -> StateT DesugarState Identity ConstrDecl
forall a b. (a -> b) -> a -> b
$ "Desugar.dsConstrDecl: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConstrDecl -> String
forall a. Show a => a -> String
show ConstrDecl
cd

dsNewConstrDecl :: NewConstrDecl -> DsM NewConstrDecl
dsNewConstrDecl :: NewConstrDecl -> DsM NewConstrDecl
dsNewConstrDecl (NewConstrDecl si :: SpanInfo
si c :: Ident
c ty :: TypeExpr
ty) = SpanInfo -> Ident -> TypeExpr -> NewConstrDecl
NewConstrDecl SpanInfo
si Ident
c (TypeExpr -> NewConstrDecl)
-> StateT DesugarState Identity TypeExpr -> DsM NewConstrDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExpr -> StateT DesugarState Identity TypeExpr
dsTypeExpr TypeExpr
ty
dsNewConstrDecl nc :: NewConstrDecl
nc = String -> DsM NewConstrDecl
forall a. String -> a
internalError (String -> DsM NewConstrDecl) -> String -> DsM NewConstrDecl
forall a b. (a -> b) -> a -> b
$ "Desugar.dsNewConstrDecl: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NewConstrDecl -> String
forall a. Show a => a -> String
show NewConstrDecl
nc

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

dsClassAndInstanceDecl :: Decl PredType -> DsM (Decl PredType)
dsClassAndInstanceDecl :: Decl PredType -> StateT DesugarState Identity (Decl PredType)
dsClassAndInstanceDecl (ClassDecl p :: SpanInfo
p li :: LayoutInfo
li cx :: Context
cx cls :: Ident
cls tv :: Ident
tv ds :: [Decl PredType]
ds) = do
  [Decl PredType]
tds' <- (Decl PredType -> StateT DesugarState Identity (Decl PredType))
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PredType -> StateT DesugarState Identity (Decl PredType)
dsTypeSig [Decl PredType]
tds
  [Decl PredType]
vds' <- [Decl PredType] -> State DesugarState [Decl PredType]
dsDeclGroup [Decl PredType]
vds
  Decl PredType -> StateT DesugarState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decl PredType -> StateT DesugarState Identity (Decl PredType))
-> Decl PredType -> StateT DesugarState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> LayoutInfo
-> Context
-> Ident
-> Ident
-> [Decl PredType]
-> Decl PredType
forall a.
SpanInfo
-> LayoutInfo -> Context -> Ident -> Ident -> [Decl a] -> Decl a
ClassDecl SpanInfo
p LayoutInfo
li Context
cx Ident
cls Ident
tv ([Decl PredType] -> Decl PredType)
-> [Decl PredType] -> Decl PredType
forall a b. (a -> b) -> a -> b
$ [Decl PredType]
tds' [Decl PredType] -> [Decl PredType] -> [Decl PredType]
forall a. [a] -> [a] -> [a]
++ [Decl PredType]
vds'
  where (tds :: [Decl PredType]
tds, vds :: [Decl PredType]
vds) = (Decl PredType -> Bool)
-> [Decl PredType] -> ([Decl PredType], [Decl PredType])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Decl PredType -> Bool
forall a. Decl a -> Bool
isTypeSig [Decl PredType]
ds
dsClassAndInstanceDecl (InstanceDecl p :: SpanInfo
p li :: LayoutInfo
li cx :: Context
cx cls :: QualIdent
cls ty :: TypeExpr
ty ds :: [Decl PredType]
ds) =
  SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl PredType]
-> Decl PredType
forall a.
SpanInfo
-> LayoutInfo
-> Context
-> QualIdent
-> TypeExpr
-> [Decl a]
-> Decl a
InstanceDecl SpanInfo
p LayoutInfo
li Context
cx QualIdent
cls TypeExpr
ty ([Decl PredType] -> Decl PredType)
-> State DesugarState [Decl PredType]
-> StateT DesugarState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Decl PredType] -> State DesugarState [Decl PredType]
dsDeclGroup [Decl PredType]
ds
dsClassAndInstanceDecl d :: Decl PredType
d = Decl PredType -> StateT DesugarState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl PredType
d

dsTypeSig :: Decl PredType -> DsM (Decl PredType)
dsTypeSig :: Decl PredType -> StateT DesugarState Identity (Decl PredType)
dsTypeSig (TypeSig s :: SpanInfo
s fs :: [Ident]
fs qty :: QualTypeExpr
qty) = SpanInfo -> [Ident] -> QualTypeExpr -> Decl PredType
forall a. SpanInfo -> [Ident] -> QualTypeExpr -> Decl a
TypeSig SpanInfo
s [Ident]
fs (QualTypeExpr -> Decl PredType)
-> StateT DesugarState Identity QualTypeExpr
-> StateT DesugarState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualTypeExpr -> StateT DesugarState Identity QualTypeExpr
dsQualTypeExpr QualTypeExpr
qty
dsTypeSig d :: Decl PredType
d                  = String -> StateT DesugarState Identity (Decl PredType)
forall a. String -> a
internalError (String -> StateT DesugarState Identity (Decl PredType))
-> String -> StateT DesugarState Identity (Decl PredType)
forall a b. (a -> b) -> a -> b
$ "Desugar.dsTypeSig: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Decl PredType -> String
forall a. Show a => a -> String
show Decl PredType
d

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

-- Generate selector functions for record labels and replace record
-- constructor declarations by ordinary constructor declarations.
dsRecordDecl :: Decl PredType -> DsM [Decl PredType]
dsRecordDecl :: Decl PredType -> State DesugarState [Decl PredType]
dsRecordDecl (DataDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs cs :: [ConstrDecl]
cs clss :: [QualIdent]
clss) = do
  ModuleIdent
m <- DsM ModuleIdent
getModuleIdent
  let qcs :: [QualIdent]
qcs = (ConstrDecl -> QualIdent) -> [ConstrDecl] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m (Ident -> QualIdent)
-> (ConstrDecl -> Ident) -> ConstrDecl -> QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstrDecl -> Ident
constrId) [ConstrDecl]
cs
  [Decl PredType]
selFuns <- (Ident -> StateT DesugarState Identity (Decl PredType))
-> [Ident] -> State DesugarState [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo
-> [QualIdent]
-> Ident
-> StateT DesugarState Identity (Decl PredType)
genSelFun SpanInfo
p [QualIdent]
qcs) ([Ident] -> [Ident]
forall a. Eq a => [a] -> [a]
nub ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ (ConstrDecl -> [Ident]) -> [ConstrDecl] -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConstrDecl -> [Ident]
recordLabels [ConstrDecl]
cs)
  [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType] -> State DesugarState [Decl PredType])
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl PredType
forall a.
SpanInfo
-> Ident -> [Ident] -> [ConstrDecl] -> [QualIdent] -> Decl a
DataDecl SpanInfo
p Ident
tc [Ident]
tvs ((ConstrDecl -> ConstrDecl) -> [ConstrDecl] -> [ConstrDecl]
forall a b. (a -> b) -> [a] -> [b]
map ConstrDecl -> ConstrDecl
unlabelConstr [ConstrDecl]
cs) [QualIdent]
clss Decl PredType -> [Decl PredType] -> [Decl PredType]
forall a. a -> [a] -> [a]
: [Decl PredType]
selFuns
dsRecordDecl (NewtypeDecl p :: SpanInfo
p tc :: Ident
tc tvs :: [Ident]
tvs nc :: NewConstrDecl
nc clss :: [QualIdent]
clss) = do
  ModuleIdent
m <- DsM ModuleIdent
getModuleIdent
  let qc :: QualIdent
qc = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m (NewConstrDecl -> Ident
nconstrId NewConstrDecl
nc)
  [Decl PredType]
selFun <- (Ident -> StateT DesugarState Identity (Decl PredType))
-> [Ident] -> State DesugarState [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo
-> [QualIdent]
-> Ident
-> StateT DesugarState Identity (Decl PredType)
genSelFun SpanInfo
p [QualIdent
qc]) (NewConstrDecl -> [Ident]
nrecordLabels NewConstrDecl
nc)
  [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType] -> State DesugarState [Decl PredType])
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> Ident
-> [Ident]
-> NewConstrDecl
-> [QualIdent]
-> Decl PredType
forall a.
SpanInfo
-> Ident -> [Ident] -> NewConstrDecl -> [QualIdent] -> Decl a
NewtypeDecl SpanInfo
p Ident
tc [Ident]
tvs (NewConstrDecl -> NewConstrDecl
unlabelNewConstr NewConstrDecl
nc) [QualIdent]
clss Decl PredType -> [Decl PredType] -> [Decl PredType]
forall a. a -> [a] -> [a]
: [Decl PredType]
selFun
dsRecordDecl d :: Decl PredType
d = [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PredType
d]

-- Generate a selector function for a single record label
genSelFun :: SpanInfo -> [QualIdent] -> Ident -> DsM (Decl PredType)
genSelFun :: SpanInfo
-> [QualIdent]
-> Ident
-> StateT DesugarState Identity (Decl PredType)
genSelFun p :: SpanInfo
p qcs :: [QualIdent]
qcs l :: Ident
l = do
  ModuleIdent
m <- DsM ModuleIdent
getModuleIdent
  ValueEnv
vEnv <- DsM ValueEnv
getValueEnv
  let ForAll _ pty :: PredType
pty = QualIdent -> ValueEnv -> TypeScheme
varType (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
m Ident
l) ValueEnv
vEnv
  SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p PredType
pty Ident
l ([Equation PredType] -> Decl PredType)
-> StateT DesugarState Identity [Equation PredType]
-> StateT DesugarState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QualIdent -> StateT DesugarState Identity [Equation PredType])
-> [QualIdent] -> StateT DesugarState Identity [Equation PredType]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (SpanInfo
-> Ident
-> QualIdent
-> StateT DesugarState Identity [Equation PredType]
genSelEqn SpanInfo
p Ident
l) [QualIdent]
qcs

-- Generate a selector equation for a label and a constructor if the label
-- is applicable, otherwise the empty list is returned.
genSelEqn :: SpanInfo -> Ident -> QualIdent -> DsM [Equation PredType]
genSelEqn :: SpanInfo
-> Ident
-> QualIdent
-> StateT DesugarState Identity [Equation PredType]
genSelEqn p :: SpanInfo
p l :: Ident
l qc :: QualIdent
qc = do
  ValueEnv
vEnv <- DsM ValueEnv
getValueEnv
  let (ls :: [Ident]
ls, ty :: TypeScheme
ty) = QualIdent -> ValueEnv -> ([Ident], TypeScheme)
conType QualIdent
qc ValueEnv
vEnv
      (tys :: [Type]
tys, ty0 :: Type
ty0) = Type -> ([Type], Type)
arrowUnapply (TypeScheme -> Type
instType TypeScheme
ty)
  case Ident -> [Ident] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Ident
l [Ident]
ls of
    Just n :: Int
n  -> do
      [(PredType, Ident)]
vs <- (Type -> DsM (PredType, Ident))
-> [Type] -> StateT DesugarState Identity [(PredType, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#rec") [Type]
tys
      let pat :: Pattern PredType
pat = PredType -> QualIdent -> [(PredType, Ident)] -> Pattern PredType
forall a. a -> QualIdent -> [(a, Ident)] -> Pattern a
constrPattern (Type -> PredType
predType Type
ty0) QualIdent
qc [(PredType, Ident)]
vs
      [Equation PredType]
-> StateT DesugarState Identity [Equation PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return [SpanInfo
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Equation PredType
forall a.
SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a
mkEquation SpanInfo
p Ident
l [Pattern PredType
pat] ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar ([(PredType, Ident)]
vs [(PredType, Ident)] -> Int -> (PredType, Ident)
forall a. [a] -> Int -> a
!! Int
n))]
    Nothing -> [Equation PredType]
-> StateT DesugarState Identity [Equation PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- Remove any labels from a data constructor declaration
unlabelConstr :: ConstrDecl -> ConstrDecl
unlabelConstr :: ConstrDecl -> ConstrDecl
unlabelConstr (RecordDecl p :: SpanInfo
p c :: Ident
c fs :: [FieldDecl]
fs) = SpanInfo -> Ident -> [TypeExpr] -> ConstrDecl
ConstrDecl SpanInfo
p Ident
c [TypeExpr]
tys
  where tys :: [TypeExpr]
tys = [TypeExpr
ty | FieldDecl _ ls :: [Ident]
ls ty :: TypeExpr
ty <- [FieldDecl]
fs, Ident
_ <- [Ident]
ls]
unlabelConstr c :: ConstrDecl
c                   = ConstrDecl
c

-- Remove any labels from a newtype constructor declaration
unlabelNewConstr :: NewConstrDecl -> NewConstrDecl
unlabelNewConstr :: NewConstrDecl -> NewConstrDecl
unlabelNewConstr (NewRecordDecl p :: SpanInfo
p nc :: Ident
nc (_, ty :: TypeExpr
ty)) = SpanInfo -> Ident -> TypeExpr -> NewConstrDecl
NewConstrDecl SpanInfo
p Ident
nc TypeExpr
ty
unlabelNewConstr c :: NewConstrDecl
c                            = NewConstrDecl
c

-- -----------------------------------------------------------------------------
-- 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.
dsDeclGroup :: [Decl PredType] -> DsM [Decl PredType]
dsDeclGroup :: [Decl PredType] -> State DesugarState [Decl PredType]
dsDeclGroup ds :: [Decl PredType]
ds = (Decl PredType -> State DesugarState [Decl PredType])
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl PredType -> State DesugarState [Decl PredType]
dsDeclLhs ((Decl PredType -> Bool) -> [Decl PredType] -> [Decl PredType]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl PredType -> Bool
forall a. Decl a -> Bool
isValueDecl [Decl PredType]
ds) State DesugarState [Decl PredType]
-> ([Decl PredType] -> State DesugarState [Decl PredType])
-> State DesugarState [Decl PredType]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Decl PredType -> StateT DesugarState Identity (Decl PredType))
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PredType -> StateT DesugarState Identity (Decl PredType)
dsDeclRhs

dsDeclLhs :: Decl PredType -> DsM [Decl PredType]
dsDeclLhs :: Decl PredType -> State DesugarState [Decl PredType]
dsDeclLhs (PatternDecl p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs) = do
  (ds' :: [Decl PredType]
ds', t' :: Pattern PredType
t') <- SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [] Pattern PredType
t
  [[Decl PredType]]
dss'      <- (Decl PredType -> State DesugarState [Decl PredType])
-> [Decl PredType]
-> StateT DesugarState Identity [[Decl PredType]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Decl PredType -> State DesugarState [Decl PredType]
dsDeclLhs [Decl PredType]
ds'
  [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType] -> State DesugarState [Decl PredType])
-> [Decl PredType] -> State DesugarState [Decl PredType]
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Pattern PredType -> Rhs PredType -> Decl PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern PredType
t' Rhs PredType
rhs Decl PredType -> [Decl PredType] -> [Decl PredType]
forall a. a -> [a] -> [a]
: [[Decl PredType]] -> [Decl PredType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Decl PredType]]
dss'
dsDeclLhs d :: Decl PredType
d                     = [Decl PredType] -> State DesugarState [Decl PredType]
forall (m :: * -> *) a. Monad m => a -> m a
return [Decl PredType
d]

-- TODO: Check if obsolete and remove
-- 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.

-- Desugaring of the right-hand-side of declarations
dsDeclRhs :: Decl PredType -> DsM (Decl PredType)
dsDeclRhs :: Decl PredType -> StateT DesugarState Identity (Decl PredType)
dsDeclRhs (FunctionDecl p :: SpanInfo
p pty :: PredType
pty f :: Ident
f eqs :: [Equation PredType]
eqs) =
  SpanInfo
-> PredType -> Ident -> [Equation PredType] -> Decl PredType
forall a. SpanInfo -> a -> Ident -> [Equation a] -> Decl a
FunctionDecl SpanInfo
p PredType
pty Ident
f ([Equation PredType] -> Decl PredType)
-> StateT DesugarState Identity [Equation PredType]
-> StateT DesugarState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Equation PredType
 -> StateT DesugarState Identity (Equation PredType))
-> [Equation PredType]
-> StateT DesugarState Identity [Equation PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Equation PredType
-> StateT DesugarState Identity (Equation PredType)
dsEquation [Equation PredType]
eqs
dsDeclRhs (PatternDecl      p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs) = SpanInfo -> Pattern PredType -> Rhs PredType -> Decl PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Decl a
PatternDecl SpanInfo
p Pattern PredType
t (Rhs PredType -> Decl PredType)
-> StateT DesugarState Identity (Rhs PredType)
-> StateT DesugarState Identity (Decl PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression PredType -> Expression PredType)
-> Rhs PredType -> StateT DesugarState Identity (Rhs PredType)
dsRhs Expression PredType -> Expression PredType
forall a. a -> a
id Rhs PredType
rhs
dsDeclRhs d :: Decl PredType
d@(FreeDecl           _ _) = Decl PredType -> StateT DesugarState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl PredType
d
dsDeclRhs d :: Decl PredType
d@(ExternalDecl       _ _) = Decl PredType -> StateT DesugarState Identity (Decl PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return Decl PredType
d
dsDeclRhs _                          =
  String -> StateT DesugarState Identity (Decl PredType)
forall a. HasCallStack => String -> a
error "Desugar.dsDeclRhs: no pattern match"

-- Desugaring of an equation
dsEquation :: Equation PredType -> DsM (Equation PredType)
dsEquation :: Equation PredType
-> StateT DesugarState Identity (Equation PredType)
dsEquation (Equation p :: SpanInfo
p lhs :: Lhs PredType
lhs rhs :: Rhs PredType
rhs) = do
  (     cs1 :: [Expression PredType]
cs1, ts1 :: [Pattern PredType]
ts1) <- [Pattern PredType]
-> DsM ([Expression PredType], [Pattern PredType])
dsNonLinearity         [Pattern PredType]
ts
  (ds1 :: [Decl PredType]
ds1, cs2 :: [Expression PredType]
cs2, ts2 :: [Pattern PredType]
ts2) <- SpanInfo
-> [Pattern PredType]
-> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])
dsFunctionalPatterns SpanInfo
p [Pattern PredType]
ts1
  (ds2 :: [Decl PredType]
ds2,      ts3 :: [Pattern PredType]
ts3) <- ([Decl PredType]
 -> Pattern PredType -> DsM ([Decl PredType], Pattern PredType))
-> [Decl PredType]
-> [Pattern PredType]
-> StateT
     DesugarState Identity ([Decl PredType], [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p) [] [Pattern PredType]
ts2
  Rhs PredType
rhs'            <- (Expression PredType -> Expression PredType)
-> Rhs PredType -> StateT DesugarState Identity (Rhs PredType)
dsRhs ([Expression PredType] -> Expression PredType -> Expression PredType
constrain [Expression PredType]
cs2 (Expression PredType -> Expression PredType)
-> (Expression PredType -> Expression PredType)
-> Expression PredType
-> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expression PredType] -> Expression PredType -> Expression PredType
constrain [Expression PredType]
cs1)
                           ([Decl PredType] -> Rhs PredType -> Rhs PredType
addDecls ([Decl PredType]
ds1 [Decl PredType] -> [Decl PredType] -> [Decl PredType]
forall a. [a] -> [a] -> [a]
++ [Decl PredType]
ds2) Rhs PredType
rhs)
  Equation PredType
-> StateT DesugarState Identity (Equation PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Equation PredType
 -> StateT DesugarState Identity (Equation PredType))
-> Equation PredType
-> StateT DesugarState Identity (Equation PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Lhs PredType -> Rhs PredType -> Equation PredType
forall a. SpanInfo -> Lhs a -> Rhs a -> Equation a
Equation SpanInfo
p (SpanInfo -> Ident -> [Pattern PredType] -> Lhs PredType
forall a. SpanInfo -> Ident -> [Pattern a] -> Lhs a
FunLhs SpanInfo
NoSpanInfo Ident
f [Pattern PredType]
ts3) Rhs PredType
rhs'
  where (f :: Ident
f, ts :: [Pattern PredType]
ts) = Lhs PredType -> (Ident, [Pattern PredType])
forall a. Lhs a -> (Ident, [Pattern a])
flatLhs Lhs PredType
lhs

-- Constrain an expression by a list of constraints.
-- @constrain []  e  ==  e@
-- @constrain c_n e  ==  (c_1 & ... & c_n) &> e@
constrain :: [Expression PredType] -> Expression PredType -> Expression PredType
constrain :: [Expression PredType] -> Expression PredType -> Expression PredType
constrain cs :: [Expression PredType]
cs e :: Expression PredType
e = if [Expression PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expression PredType]
cs then Expression PredType
e else (Expression PredType -> Expression PredType -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Expression PredType -> Expression PredType -> Expression PredType
(&) [Expression PredType]
cs Expression PredType -> Expression PredType -> Expression PredType
&> Expression PredType
e

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

dsRhs :: (Expression PredType -> Expression PredType)
      -> Rhs PredType -> DsM (Rhs PredType)
dsRhs :: (Expression PredType -> Expression PredType)
-> Rhs PredType -> StateT DesugarState Identity (Rhs PredType)
dsRhs f :: Expression PredType -> Expression PredType
f rhs :: Rhs PredType
rhs =   Expression PredType
-> (Expression PredType -> Expression PredType)
-> Rhs PredType
-> DsM (Expression PredType)
expandRhs (Type -> Expression PredType
prelFailed (Rhs PredType -> Type
forall a. Typeable a => a -> Type
typeOf Rhs PredType
rhs)) Expression PredType -> Expression PredType
f Rhs PredType
rhs
            DsM (Expression PredType)
-> (Expression PredType -> DsM (Expression PredType))
-> DsM (Expression PredType)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr (Rhs PredType -> SpanInfo
forall a. HasSpanInfo a => a -> SpanInfo
getSpanInfo Rhs PredType
rhs)
            DsM (Expression PredType)
-> (Expression PredType
    -> StateT DesugarState Identity (Rhs PredType))
-> StateT DesugarState Identity (Rhs PredType)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rhs PredType -> StateT DesugarState Identity (Rhs PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Rhs PredType -> StateT DesugarState Identity (Rhs PredType))
-> (Expression PredType -> Rhs PredType)
-> Expression PredType
-> StateT DesugarState Identity (Rhs PredType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanInfo -> Expression PredType -> Rhs PredType
forall a. SpanInfo -> Expression a -> Rhs a
simpleRhs (Rhs PredType -> SpanInfo
forall a. HasSpanInfo a => a -> SpanInfo
getSpanInfo Rhs PredType
rhs)

expandRhs :: Expression PredType -> (Expression PredType -> Expression PredType)
          -> Rhs PredType -> DsM (Expression PredType)
expandRhs :: Expression PredType
-> (Expression PredType -> Expression PredType)
-> Rhs PredType
-> DsM (Expression PredType)
expandRhs _  f :: Expression PredType -> Expression PredType
f (SimpleRhs _ _ e :: Expression PredType
e ds :: [Decl PredType]
ds) = Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ [Decl PredType] -> Expression PredType -> Expression PredType
forall a. [Decl a] -> Expression a -> Expression a
mkLet [Decl PredType]
ds (Expression PredType -> Expression PredType
f Expression PredType
e)
expandRhs e0 :: Expression PredType
e0 f :: Expression PredType -> Expression PredType
f (GuardedRhs _ _ es :: [CondExpr PredType]
es ds :: [Decl PredType]
ds) = [Decl PredType] -> Expression PredType -> Expression PredType
forall a. [Decl a] -> Expression a -> Expression a
mkLet [Decl PredType]
ds (Expression PredType -> Expression PredType)
-> (Expression PredType -> Expression PredType)
-> Expression PredType
-> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression PredType -> Expression PredType
f
                                     (Expression PredType -> Expression PredType)
-> DsM (Expression PredType) -> DsM (Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType
-> [CondExpr PredType] -> DsM (Expression PredType)
expandGuards Expression PredType
e0 [CondExpr PredType]
es

expandGuards :: Expression PredType -> [CondExpr PredType]
             -> DsM (Expression PredType)
expandGuards :: Expression PredType
-> [CondExpr PredType] -> DsM (Expression PredType)
expandGuards e0 :: Expression PredType
e0 es :: [CondExpr PredType]
es =
  Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ if [CondExpr PredType] -> Bool
boolGuards [CondExpr PredType]
es then (CondExpr PredType -> Expression PredType -> Expression PredType)
-> Expression PredType
-> [CondExpr PredType]
-> Expression PredType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CondExpr PredType -> Expression PredType -> Expression PredType
forall a. CondExpr a -> Expression a -> Expression a
mkIfThenElse Expression PredType
e0 [CondExpr PredType]
es else [CondExpr PredType] -> Expression PredType
mkCond [CondExpr PredType]
es
  where
  mkIfThenElse :: CondExpr a -> Expression a -> Expression a
mkIfThenElse (CondExpr _ g :: Expression a
g e :: Expression a
e) = SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
IfThenElse SpanInfo
NoSpanInfo Expression a
g Expression a
e
  mkCond :: [CondExpr PredType] -> Expression PredType
mkCond [CondExpr _ g :: Expression PredType
g e :: Expression PredType
e] = Expression PredType
g Expression PredType -> Expression PredType -> Expression PredType
&> Expression PredType
e
  mkCond _                = String -> Expression PredType
forall a. HasCallStack => String -> a
error "Desugar.expandGuards.mkCond: non-unary list"

boolGuards :: [CondExpr PredType] -> Bool
boolGuards :: [CondExpr PredType] -> Bool
boolGuards []                    = Bool
False
boolGuards (CondExpr _ g :: Expression PredType
g _ : es :: [CondExpr PredType]
es) = Bool -> Bool
not ([CondExpr PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CondExpr PredType]
es) Bool -> Bool -> Bool
|| Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
g Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
boolType

-- Add additional declarations to a right-hand side
addDecls :: [Decl PredType] -> Rhs PredType -> Rhs PredType
addDecls :: [Decl PredType] -> Rhs PredType -> Rhs PredType
addDecls ds :: [Decl PredType]
ds (SimpleRhs p :: SpanInfo
p li :: LayoutInfo
li e :: Expression PredType
e ds' :: [Decl PredType]
ds') = SpanInfo
-> LayoutInfo
-> Expression PredType
-> [Decl PredType]
-> Rhs PredType
forall a.
SpanInfo -> LayoutInfo -> Expression a -> [Decl a] -> Rhs a
SimpleRhs SpanInfo
p LayoutInfo
li Expression PredType
e ([Decl PredType]
ds [Decl PredType] -> [Decl PredType] -> [Decl PredType]
forall a. [a] -> [a] -> [a]
++ [Decl PredType]
ds')
addDecls ds :: [Decl PredType]
ds (GuardedRhs spi :: SpanInfo
spi li :: LayoutInfo
li es :: [CondExpr PredType]
es ds' :: [Decl PredType]
ds') = SpanInfo
-> LayoutInfo
-> [CondExpr PredType]
-> [Decl PredType]
-> Rhs PredType
forall a.
SpanInfo -> LayoutInfo -> [CondExpr a] -> [Decl a] -> Rhs a
GuardedRhs SpanInfo
spi LayoutInfo
li [CondExpr PredType]
es ([Decl PredType]
ds [Decl PredType] -> [Decl PredType] -> [Decl PredType]
forall a. [a] -> [a] -> [a]
++ [Decl PredType]
ds')

-- -----------------------------------------------------------------------------
-- Desugaring of non-linear patterns
-- -----------------------------------------------------------------------------

-- 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.
-- Non-linear patterns inside single functional patterns are not desugared,
-- as this special case is handled later.
dsNonLinearity :: [Pattern PredType]
               -> DsM ([Expression PredType], [Pattern PredType])
dsNonLinearity :: [Pattern PredType]
-> DsM ([Expression PredType], [Pattern PredType])
dsNonLinearity ts :: [Pattern PredType]
ts = do
  ((_, cs :: [Expression PredType]
cs), ts' :: [Pattern PredType]
ts') <- (NonLinearEnv
 -> Pattern PredType
 -> StateT DesugarState Identity (NonLinearEnv, Pattern PredType))
-> NonLinearEnv
-> [Pattern PredType]
-> StateT DesugarState Identity (NonLinearEnv, [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear (Set Ident
forall a. Set a
Set.empty, []) [Pattern PredType]
ts
  ([Expression PredType], [Pattern PredType])
-> DsM ([Expression PredType], [Pattern PredType])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Expression PredType] -> [Expression PredType]
forall a. [a] -> [a]
reverse [Expression PredType]
cs, [Pattern PredType]
ts')

type NonLinearEnv = (Set.Set Ident, [Expression PredType])

dsNonLinear :: NonLinearEnv -> Pattern PredType
            -> DsM (NonLinearEnv, Pattern PredType)
dsNonLinear :: NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear env :: NonLinearEnv
env l :: Pattern PredType
l@(LiteralPattern        _ _ _) = (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonLinearEnv
env, Pattern PredType
l)
dsNonLinear env :: NonLinearEnv
env n :: Pattern PredType
n@(NegativePattern       _ _ _) = (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonLinearEnv
env, Pattern PredType
n)
dsNonLinear env :: NonLinearEnv
env t :: Pattern PredType
t@(VariablePattern       _ _ v :: Ident
v)
  | Ident -> Bool
isAnonId Ident
v         = (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonLinearEnv
env, Pattern PredType
t)
  | Ident
v Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Ident
vis = do
    (PredType, Ident)
v' <- String -> Pattern PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#nonlinear" Pattern PredType
t
    (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Set Ident
vis, Ident -> (PredType, Ident) -> Expression PredType
mkStrictEquality Ident
v (PredType, Ident)
v' Expression PredType
-> [Expression PredType] -> [Expression PredType]
forall a. a -> [a] -> [a]
: [Expression PredType]
eqs),
             (PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) (PredType, Ident)
v')
  | Bool
otherwise          = (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert Ident
v Set Ident
vis, [Expression PredType]
eqs), Pattern PredType
t)
  where (vis :: Set Ident
vis, eqs :: [Expression PredType]
eqs) = NonLinearEnv
env
dsNonLinear env :: NonLinearEnv
env (ConstructorPattern _ pty :: PredType
pty c :: QualIdent
c ts :: [Pattern PredType]
ts)
  = ([Pattern PredType] -> Pattern PredType)
-> (NonLinearEnv, [Pattern PredType])
-> (NonLinearEnv, Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
c) ((NonLinearEnv, [Pattern PredType])
 -> (NonLinearEnv, Pattern PredType))
-> StateT DesugarState Identity (NonLinearEnv, [Pattern PredType])
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NonLinearEnv
 -> Pattern PredType
 -> StateT DesugarState Identity (NonLinearEnv, Pattern PredType))
-> NonLinearEnv
-> [Pattern PredType]
-> StateT DesugarState Identity (NonLinearEnv, [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear NonLinearEnv
env [Pattern PredType]
ts
dsNonLinear env :: NonLinearEnv
env (InfixPattern   _ pty :: PredType
pty t1 :: Pattern PredType
t1 op :: QualIdent
op t2 :: Pattern PredType
t2) = do
  (env1 :: NonLinearEnv
env1, t1' :: Pattern PredType
t1') <- NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear NonLinearEnv
env  Pattern PredType
t1
  (env2 :: NonLinearEnv
env2, t2' :: Pattern PredType
t2') <- NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear NonLinearEnv
env1 Pattern PredType
t2
  (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonLinearEnv
env2, SpanInfo
-> PredType
-> Pattern PredType
-> QualIdent
-> Pattern PredType
-> Pattern PredType
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
NoSpanInfo PredType
pty Pattern PredType
t1' QualIdent
op Pattern PredType
t2')
dsNonLinear env :: NonLinearEnv
env (ParenPattern              _ t :: Pattern PredType
t) =
  (Pattern PredType -> Pattern PredType)
-> (NonLinearEnv, Pattern PredType)
-> (NonLinearEnv, Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Pattern a -> Pattern a
ParenPattern SpanInfo
NoSpanInfo) ((NonLinearEnv, Pattern PredType)
 -> (NonLinearEnv, Pattern PredType))
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear NonLinearEnv
env Pattern PredType
t
dsNonLinear env :: NonLinearEnv
env (RecordPattern      _ pty :: PredType
pty c :: QualIdent
c fs :: [Field (Pattern PredType)]
fs) =
  ([Field (Pattern PredType)] -> Pattern PredType)
-> (NonLinearEnv, [Field (Pattern PredType)])
-> (NonLinearEnv, Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo
-> PredType
-> QualIdent
-> [Field (Pattern PredType)]
-> Pattern PredType
forall a.
SpanInfo -> a -> QualIdent -> [Field (Pattern a)] -> Pattern a
RecordPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
c)
  ((NonLinearEnv, [Field (Pattern PredType)])
 -> (NonLinearEnv, Pattern PredType))
-> StateT
     DesugarState Identity (NonLinearEnv, [Field (Pattern PredType)])
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NonLinearEnv
 -> Field (Pattern PredType)
 -> StateT
      DesugarState Identity (NonLinearEnv, Field (Pattern PredType)))
-> NonLinearEnv
-> [Field (Pattern PredType)]
-> StateT
     DesugarState Identity (NonLinearEnv, [Field (Pattern PredType)])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM ((NonLinearEnv
 -> Pattern PredType
 -> StateT DesugarState Identity (NonLinearEnv, Pattern PredType))
-> NonLinearEnv
-> Field (Pattern PredType)
-> StateT
     DesugarState Identity (NonLinearEnv, Field (Pattern PredType))
forall a b.
(a -> b -> DsM (a, b)) -> a -> Field b -> DsM (a, Field b)
dsField NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear) NonLinearEnv
env [Field (Pattern PredType)]
fs
dsNonLinear env :: NonLinearEnv
env (TuplePattern             _ ts :: [Pattern PredType]
ts) =
  ([Pattern PredType] -> Pattern PredType)
-> (NonLinearEnv, [Pattern PredType])
-> (NonLinearEnv, Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> [Pattern a] -> Pattern a
TuplePattern SpanInfo
NoSpanInfo) ((NonLinearEnv, [Pattern PredType])
 -> (NonLinearEnv, Pattern PredType))
-> StateT DesugarState Identity (NonLinearEnv, [Pattern PredType])
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NonLinearEnv
 -> Pattern PredType
 -> StateT DesugarState Identity (NonLinearEnv, Pattern PredType))
-> NonLinearEnv
-> [Pattern PredType]
-> StateT DesugarState Identity (NonLinearEnv, [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear NonLinearEnv
env [Pattern PredType]
ts
dsNonLinear env :: NonLinearEnv
env (ListPattern          _ pty :: PredType
pty ts :: [Pattern PredType]
ts) =
  ([Pattern PredType] -> Pattern PredType)
-> (NonLinearEnv, [Pattern PredType])
-> (NonLinearEnv, Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> PredType -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> [Pattern a] -> Pattern a
ListPattern SpanInfo
NoSpanInfo PredType
pty) ((NonLinearEnv, [Pattern PredType])
 -> (NonLinearEnv, Pattern PredType))
-> StateT DesugarState Identity (NonLinearEnv, [Pattern PredType])
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NonLinearEnv
 -> Pattern PredType
 -> StateT DesugarState Identity (NonLinearEnv, Pattern PredType))
-> NonLinearEnv
-> [Pattern PredType]
-> StateT DesugarState Identity (NonLinearEnv, [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear NonLinearEnv
env [Pattern PredType]
ts
dsNonLinear env :: NonLinearEnv
env (AsPattern               _ v :: Ident
v t :: Pattern PredType
t) = do
  let pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf Pattern PredType
t
  (env1 :: NonLinearEnv
env1, pat :: Pattern PredType
pat) <- NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear NonLinearEnv
env (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo PredType
pty Ident
v)
  let VariablePattern _ _ v' :: Ident
v' = Pattern PredType
pat
  (env2 :: NonLinearEnv
env2, t' :: Pattern PredType
t') <- NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear NonLinearEnv
env1 Pattern PredType
t
  (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonLinearEnv
env2, SpanInfo -> Ident -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
NoSpanInfo Ident
v' Pattern PredType
t')
dsNonLinear env :: NonLinearEnv
env (LazyPattern               _ t :: Pattern PredType
t) =
  (Pattern PredType -> Pattern PredType)
-> (NonLinearEnv, Pattern PredType)
-> (NonLinearEnv, Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Pattern a -> Pattern a
LazyPattern SpanInfo
NoSpanInfo) ((NonLinearEnv, Pattern PredType)
 -> (NonLinearEnv, Pattern PredType))
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinear NonLinearEnv
env Pattern PredType
t
dsNonLinear env :: NonLinearEnv
env fp :: Pattern PredType
fp@(FunctionPattern    _ _ _ _) = NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinearFuncPat NonLinearEnv
env Pattern PredType
fp
dsNonLinear env :: NonLinearEnv
env fp :: Pattern PredType
fp@(InfixFuncPattern _ _ _ _ _) = NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinearFuncPat NonLinearEnv
env Pattern PredType
fp

dsNonLinearFuncPat :: NonLinearEnv -> Pattern PredType
                   -> DsM (NonLinearEnv, Pattern PredType)
dsNonLinearFuncPat :: NonLinearEnv
-> Pattern PredType
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
dsNonLinearFuncPat (vis :: Set Ident
vis, eqs :: [Expression PredType]
eqs) fp :: Pattern PredType
fp = do
  let fpVars :: [(PredType, Ident)]
fpVars = ((Ident, Int, PredType) -> (PredType, Ident))
-> [(Ident, Int, PredType)] -> [(PredType, Ident)]
forall a b. (a -> b) -> [a] -> [b]
map (\(v :: Ident
v, _, pty :: PredType
pty) -> (PredType
pty, Ident
v)) ([(Ident, Int, PredType)] -> [(PredType, Ident)])
-> [(Ident, Int, PredType)] -> [(PredType, Ident)]
forall a b. (a -> b) -> a -> b
$ Pattern PredType -> [(Ident, Int, PredType)]
forall t.
(Eq t, Typeable t, ValueType t) =>
Pattern t -> [(Ident, Int, t)]
patternVars Pattern PredType
fp
      vs :: [(PredType, Ident)]
vs     = ((PredType, Ident) -> Bool)
-> [(PredType, Ident)] -> [(PredType, Ident)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Ident
vis) (Ident -> Bool)
-> ((PredType, Ident) -> Ident) -> (PredType, Ident) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PredType, Ident) -> Ident
forall a b. (a, b) -> b
snd) [(PredType, Ident)]
fpVars
  [(PredType, Ident)]
vs' <- ((PredType, Ident) -> DsM (PredType, Ident))
-> [(PredType, Ident)]
-> StateT DesugarState Identity [(PredType, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Pattern PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#nonlinear" (Pattern PredType -> DsM (PredType, Ident))
-> ((PredType, Ident) -> Pattern PredType)
-> (PredType, Ident)
-> DsM (PredType, Ident)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo)) [(PredType, Ident)]
vs
  let vis' :: Set Ident
vis' = ((PredType, Ident) -> Set Ident -> Set Ident)
-> Set Ident -> [(PredType, Ident)] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert (Ident -> Set Ident -> Set Ident)
-> ((PredType, Ident) -> Ident)
-> (PredType, Ident)
-> Set Ident
-> Set Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PredType, Ident) -> Ident
forall a b. (a, b) -> b
snd) Set Ident
vis [(PredType, Ident)]
fpVars
      fp' :: Pattern PredType
fp'  = [(Ident, Ident)] -> Pattern PredType -> Pattern PredType
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat ([Ident] -> [Ident] -> [(Ident, Ident)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((PredType, Ident) -> Ident) -> [(PredType, Ident)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (PredType, Ident) -> Ident
forall a b. (a, b) -> b
snd [(PredType, Ident)]
vs) (((PredType, Ident) -> Ident) -> [(PredType, Ident)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (PredType, Ident) -> Ident
forall a b. (a, b) -> b
snd [(PredType, Ident)]
vs')) Pattern PredType
fp
  (NonLinearEnv, Pattern PredType)
-> StateT DesugarState Identity (NonLinearEnv, Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Set Ident
vis', (Ident -> (PredType, Ident) -> Expression PredType)
-> [Ident] -> [(PredType, Ident)] -> [Expression PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Ident -> (PredType, Ident) -> Expression PredType
mkStrictEquality (((PredType, Ident) -> Ident) -> [(PredType, Ident)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (PredType, Ident) -> Ident
forall a b. (a, b) -> b
snd [(PredType, Ident)]
vs) [(PredType, Ident)]
vs' [Expression PredType]
-> [Expression PredType] -> [Expression PredType]
forall a. [a] -> [a] -> [a]
++ [Expression PredType]
eqs), Pattern PredType
fp')

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

substPat :: [(Ident, Ident)] -> Pattern a -> Pattern a
substPat :: [(Ident, Ident)] -> Pattern a -> Pattern a
substPat _ l :: Pattern a
l@(LiteralPattern        _ _ _) = Pattern a
l
substPat _ n :: Pattern a
n@(NegativePattern       _ _ _) = Pattern a
n
substPat s :: [(Ident, Ident)]
s (VariablePattern         _ a :: a
a v :: Ident
v) =
  SpanInfo -> a -> Ident -> Pattern a
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo a
a (Ident -> Pattern a) -> Ident -> Pattern a
forall a b. (a -> b) -> a -> b
$ Ident -> Maybe Ident -> Ident
forall a. a -> Maybe a -> a
fromMaybe Ident
v (Ident -> [(Ident, Ident)] -> Maybe Ident
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
v [(Ident, Ident)]
s)

substPat s :: [(Ident, Ident)]
s (ConstructorPattern   _ a :: a
a c :: QualIdent
c ps :: [Pattern a]
ps) =
  SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo a
a QualIdent
c ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Pattern a -> Pattern a) -> [Pattern a] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s) [Pattern a]
ps
substPat s :: [(Ident, Ident)]
s (InfixPattern     _ a :: a
a p1 :: Pattern a
p1 op :: QualIdent
op p2 :: Pattern a
p2) =
  SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
NoSpanInfo a
a ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s Pattern a
p1) QualIdent
op ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s Pattern a
p2)
substPat s :: [(Ident, Ident)]
s (ParenPattern              _ p :: Pattern a
p) =
  SpanInfo -> Pattern a -> Pattern a
forall a. SpanInfo -> Pattern a -> Pattern a
ParenPattern SpanInfo
NoSpanInfo ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s Pattern a
p)
substPat s :: [(Ident, Ident)]
s (RecordPattern        _ a :: a
a c :: QualIdent
c fs :: [Field (Pattern a)]
fs) =
  SpanInfo -> a -> QualIdent -> [Field (Pattern a)] -> Pattern a
forall a.
SpanInfo -> a -> QualIdent -> [Field (Pattern a)] -> Pattern a
RecordPattern SpanInfo
NoSpanInfo a
a QualIdent
c ((Field (Pattern a) -> Field (Pattern a))
-> [Field (Pattern a)] -> [Field (Pattern a)]
forall a b. (a -> b) -> [a] -> [b]
map Field (Pattern a) -> Field (Pattern a)
forall a. Field (Pattern a) -> Field (Pattern a)
substField [Field (Pattern a)]
fs)
  where substField :: Field (Pattern a) -> Field (Pattern a)
substField (Field pos :: SpanInfo
pos l :: QualIdent
l pat :: Pattern a
pat) = SpanInfo -> QualIdent -> Pattern a -> Field (Pattern a)
forall a. SpanInfo -> QualIdent -> a -> Field a
Field SpanInfo
pos QualIdent
l ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s Pattern a
pat)
substPat s :: [(Ident, Ident)]
s (TuplePattern             _ ps :: [Pattern a]
ps) =
  SpanInfo -> [Pattern a] -> Pattern a
forall a. SpanInfo -> [Pattern a] -> Pattern a
TuplePattern SpanInfo
NoSpanInfo ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Pattern a -> Pattern a) -> [Pattern a] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s) [Pattern a]
ps
substPat s :: [(Ident, Ident)]
s (ListPattern            _ a :: a
a ps :: [Pattern a]
ps) =
  SpanInfo -> a -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> [Pattern a] -> Pattern a
ListPattern SpanInfo
NoSpanInfo a
a ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Pattern a -> Pattern a) -> [Pattern a] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s) [Pattern a]
ps
substPat s :: [(Ident, Ident)]
s (AsPattern               _ v :: Ident
v p :: Pattern a
p) =
  SpanInfo -> Ident -> Pattern a -> Pattern a
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
NoSpanInfo (Ident -> Maybe Ident -> Ident
forall a. a -> Maybe a -> a
fromMaybe Ident
v (Ident -> [(Ident, Ident)] -> Maybe Ident
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
v [(Ident, Ident)]
s)) ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s Pattern a
p)
substPat s :: [(Ident, Ident)]
s (LazyPattern               _ p :: Pattern a
p) =
  SpanInfo -> Pattern a -> Pattern a
forall a. SpanInfo -> Pattern a -> Pattern a
LazyPattern SpanInfo
NoSpanInfo ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s Pattern a
p)
substPat s :: [(Ident, Ident)]
s (FunctionPattern      _ a :: a
a f :: QualIdent
f ps :: [Pattern a]
ps) =
  SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
NoSpanInfo a
a QualIdent
f ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Pattern a -> Pattern a) -> [Pattern a] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s) [Pattern a]
ps
substPat s :: [(Ident, Ident)]
s (InfixFuncPattern _ a :: a
a p1 :: Pattern a
p1 op :: QualIdent
op p2 :: Pattern a
p2) =
  SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixFuncPattern SpanInfo
NoSpanInfo a
a ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s Pattern a
p1) QualIdent
op ([(Ident, Ident)] -> Pattern a -> Pattern a
forall a. [(Ident, Ident)] -> Pattern a -> Pattern a
substPat [(Ident, Ident)]
s Pattern a
p2)

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

dsFunctionalPatterns
  :: SpanInfo -> [Pattern PredType]
  -> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])
dsFunctionalPatterns :: SpanInfo
-> [Pattern PredType]
-> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])
dsFunctionalPatterns p :: SpanInfo
p ts :: [Pattern PredType]
ts = do
  -- extract functional patterns
  (bs :: [LazyBinding]
bs, ts' :: [Pattern PredType]
ts') <- ([LazyBinding]
 -> Pattern PredType
 -> StateT DesugarState Identity ([LazyBinding], Pattern PredType))
-> [LazyBinding]
-> [Pattern PredType]
-> StateT DesugarState Identity ([LazyBinding], [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP [] [Pattern PredType]
ts
  -- generate declarations of free variables and constraints
  let (ds :: [Decl PredType]
ds, cs :: [Expression PredType]
cs) = SpanInfo
-> [(Ident, Int, PredType)]
-> [LazyBinding]
-> ([Decl PredType], [Expression PredType])
genFPExpr SpanInfo
p ((Pattern PredType -> [(Ident, Int, PredType)])
-> [Pattern PredType] -> [(Ident, Int, PredType)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pattern PredType -> [(Ident, Int, PredType)]
forall t.
(Eq t, Typeable t, ValueType t) =>
Pattern t -> [(Ident, Int, t)]
patternVars [Pattern PredType]
ts') ([LazyBinding] -> [LazyBinding]
forall a. [a] -> [a]
reverse [LazyBinding]
bs)
  -- return (declarations, constraints, desugared patterns)
  ([Decl PredType], [Expression PredType], [Pattern PredType])
-> DsM ([Decl PredType], [Expression PredType], [Pattern PredType])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType]
ds, [Expression PredType]
cs, [Pattern PredType]
ts')

type LazyBinding = (Pattern PredType, (PredType, Ident))

elimFP :: [LazyBinding] -> Pattern PredType
       -> DsM ([LazyBinding], Pattern PredType)
elimFP :: [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP bs :: [LazyBinding]
bs p :: Pattern PredType
p@(LiteralPattern        _ _ _) = ([LazyBinding], Pattern PredType)
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LazyBinding]
bs, Pattern PredType
p)
elimFP bs :: [LazyBinding]
bs p :: Pattern PredType
p@(NegativePattern       _ _ _) = ([LazyBinding], Pattern PredType)
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LazyBinding]
bs, Pattern PredType
p)
elimFP bs :: [LazyBinding]
bs p :: Pattern PredType
p@(VariablePattern       _ _ _) = ([LazyBinding], Pattern PredType)
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LazyBinding]
bs, Pattern PredType
p)
elimFP bs :: [LazyBinding]
bs (ConstructorPattern _ pty :: PredType
pty c :: QualIdent
c ts :: [Pattern PredType]
ts) =
  ([Pattern PredType] -> Pattern PredType)
-> ([LazyBinding], [Pattern PredType])
-> ([LazyBinding], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo  PredType
pty QualIdent
c) (([LazyBinding], [Pattern PredType])
 -> ([LazyBinding], Pattern PredType))
-> StateT DesugarState Identity ([LazyBinding], [Pattern PredType])
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([LazyBinding]
 -> Pattern PredType
 -> StateT DesugarState Identity ([LazyBinding], Pattern PredType))
-> [LazyBinding]
-> [Pattern PredType]
-> StateT DesugarState Identity ([LazyBinding], [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP [LazyBinding]
bs [Pattern PredType]
ts
elimFP bs :: [LazyBinding]
bs (InfixPattern   _ pty :: PredType
pty t1 :: Pattern PredType
t1 op :: QualIdent
op t2 :: Pattern PredType
t2) = do
  (bs1 :: [LazyBinding]
bs1, t1' :: Pattern PredType
t1') <- [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP [LazyBinding]
bs  Pattern PredType
t1
  (bs2 :: [LazyBinding]
bs2, t2' :: Pattern PredType
t2') <- [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP [LazyBinding]
bs1 Pattern PredType
t2
  ([LazyBinding], Pattern PredType)
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LazyBinding]
bs2, SpanInfo
-> PredType
-> Pattern PredType
-> QualIdent
-> Pattern PredType
-> Pattern PredType
forall a.
SpanInfo -> a -> Pattern a -> QualIdent -> Pattern a -> Pattern a
InfixPattern SpanInfo
NoSpanInfo PredType
pty Pattern PredType
t1' QualIdent
op Pattern PredType
t2')
elimFP bs :: [LazyBinding]
bs (ParenPattern              _ t :: Pattern PredType
t) =
  (Pattern PredType -> Pattern PredType)
-> ([LazyBinding], Pattern PredType)
-> ([LazyBinding], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Pattern a -> Pattern a
ParenPattern SpanInfo
NoSpanInfo) (([LazyBinding], Pattern PredType)
 -> ([LazyBinding], Pattern PredType))
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP [LazyBinding]
bs Pattern PredType
t
elimFP bs :: [LazyBinding]
bs (RecordPattern      _ pty :: PredType
pty c :: QualIdent
c fs :: [Field (Pattern PredType)]
fs) =
  ([Field (Pattern PredType)] -> Pattern PredType)
-> ([LazyBinding], [Field (Pattern PredType)])
-> ([LazyBinding], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo
-> PredType
-> QualIdent
-> [Field (Pattern PredType)]
-> Pattern PredType
forall a.
SpanInfo -> a -> QualIdent -> [Field (Pattern a)] -> Pattern a
RecordPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
c) (([LazyBinding], [Field (Pattern PredType)])
 -> ([LazyBinding], Pattern PredType))
-> StateT
     DesugarState Identity ([LazyBinding], [Field (Pattern PredType)])
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([LazyBinding]
 -> Field (Pattern PredType)
 -> StateT
      DesugarState Identity ([LazyBinding], Field (Pattern PredType)))
-> [LazyBinding]
-> [Field (Pattern PredType)]
-> StateT
     DesugarState Identity ([LazyBinding], [Field (Pattern PredType)])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (([LazyBinding]
 -> Pattern PredType
 -> StateT DesugarState Identity ([LazyBinding], Pattern PredType))
-> [LazyBinding]
-> Field (Pattern PredType)
-> StateT
     DesugarState Identity ([LazyBinding], Field (Pattern PredType))
forall a b.
(a -> b -> DsM (a, b)) -> a -> Field b -> DsM (a, Field b)
dsField [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP) [LazyBinding]
bs [Field (Pattern PredType)]
fs
elimFP bs :: [LazyBinding]
bs (TuplePattern             _ ts :: [Pattern PredType]
ts) =
  ([Pattern PredType] -> Pattern PredType)
-> ([LazyBinding], [Pattern PredType])
-> ([LazyBinding], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> [Pattern a] -> Pattern a
TuplePattern SpanInfo
NoSpanInfo) (([LazyBinding], [Pattern PredType])
 -> ([LazyBinding], Pattern PredType))
-> StateT DesugarState Identity ([LazyBinding], [Pattern PredType])
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([LazyBinding]
 -> Pattern PredType
 -> StateT DesugarState Identity ([LazyBinding], Pattern PredType))
-> [LazyBinding]
-> [Pattern PredType]
-> StateT DesugarState Identity ([LazyBinding], [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP [LazyBinding]
bs [Pattern PredType]
ts
elimFP bs :: [LazyBinding]
bs (ListPattern          _ pty :: PredType
pty ts :: [Pattern PredType]
ts) =
  ([Pattern PredType] -> Pattern PredType)
-> ([LazyBinding], [Pattern PredType])
-> ([LazyBinding], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> PredType -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> [Pattern a] -> Pattern a
ListPattern SpanInfo
NoSpanInfo PredType
pty) (([LazyBinding], [Pattern PredType])
 -> ([LazyBinding], Pattern PredType))
-> StateT DesugarState Identity ([LazyBinding], [Pattern PredType])
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([LazyBinding]
 -> Pattern PredType
 -> StateT DesugarState Identity ([LazyBinding], Pattern PredType))
-> [LazyBinding]
-> [Pattern PredType]
-> StateT DesugarState Identity ([LazyBinding], [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP [LazyBinding]
bs [Pattern PredType]
ts
elimFP bs :: [LazyBinding]
bs (AsPattern               _ v :: Ident
v t :: Pattern PredType
t) =
  (Pattern PredType -> Pattern PredType)
-> ([LazyBinding], Pattern PredType)
-> ([LazyBinding], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> Ident -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
NoSpanInfo Ident
v) (([LazyBinding], Pattern PredType)
 -> ([LazyBinding], Pattern PredType))
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP [LazyBinding]
bs Pattern PredType
t
elimFP bs :: [LazyBinding]
bs (LazyPattern               _ t :: Pattern PredType
t) =
  (Pattern PredType -> Pattern PredType)
-> ([LazyBinding], Pattern PredType)
-> ([LazyBinding], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Pattern a -> Pattern a
LazyPattern SpanInfo
NoSpanInfo) (([LazyBinding], Pattern PredType)
 -> ([LazyBinding], Pattern PredType))
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LazyBinding]
-> Pattern PredType
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
elimFP [LazyBinding]
bs Pattern PredType
t
elimFP bs :: [LazyBinding]
bs p :: Pattern PredType
p@(FunctionPattern    _  _ _ _) = do
 (pty :: PredType
pty, v :: Ident
v) <- String -> Pattern PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#funpatt" Pattern PredType
p
 ([LazyBinding], Pattern PredType)
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Pattern PredType
p, (PredType
pty, Ident
v)) LazyBinding -> [LazyBinding] -> [LazyBinding]
forall a. a -> [a] -> [a]
: [LazyBinding]
bs, SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo PredType
pty Ident
v)
elimFP bs :: [LazyBinding]
bs p :: Pattern PredType
p@(InfixFuncPattern  _ _ _ _ _) = do
 (pty :: PredType
pty, v :: Ident
v) <- String -> Pattern PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#funpatt" Pattern PredType
p
 ([LazyBinding], Pattern PredType)
-> StateT DesugarState Identity ([LazyBinding], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Pattern PredType
p, (PredType
pty, Ident
v)) LazyBinding -> [LazyBinding] -> [LazyBinding]
forall a. a -> [a] -> [a]
: [LazyBinding]
bs, SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo PredType
pty Ident
v)

genFPExpr :: SpanInfo -> [(Ident, Int, PredType)] -> [LazyBinding]
          -> ([Decl PredType], [Expression PredType])
genFPExpr :: SpanInfo
-> [(Ident, Int, PredType)]
-> [LazyBinding]
-> ([Decl PredType], [Expression PredType])
genFPExpr p :: SpanInfo
p vs :: [(Ident, Int, PredType)]
vs bs :: [LazyBinding]
bs
  | [LazyBinding] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LazyBinding]
bs   = ([]               , [])
  | [(Ident, Int, PredType)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Ident, Int, PredType)]
free = ([]               , [Expression PredType]
cs)
  | Bool
otherwise = ([SpanInfo -> [Var PredType] -> Decl PredType
forall a. SpanInfo -> [Var a] -> Decl a
FreeDecl SpanInfo
p (((Ident, Int, PredType) -> Var PredType)
-> [(Ident, Int, PredType)] -> [Var PredType]
forall a b. (a -> b) -> [a] -> [b]
map (\(v :: Ident
v, _, pty :: PredType
pty) -> PredType -> Ident -> Var PredType
forall a. a -> Ident -> Var a
Var PredType
pty Ident
v) [(Ident, Int, PredType)]
free)], [Expression PredType]
cs)
  where
  mkLB :: LazyBinding -> [Expression PredType]
mkLB (t :: Pattern PredType
t, (pty :: PredType
pty, v :: Ident
v)) = let (t' :: Expression PredType
t', es :: [Expression PredType]
es) = Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr Pattern PredType
t
                       in  (Expression PredType
t' Expression PredType -> Expression PredType -> Expression PredType
=:<= PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar PredType
pty Ident
v) Expression PredType
-> [Expression PredType] -> [Expression PredType]
forall a. a -> [a] -> [a]
: [Expression PredType]
es
  cs :: [Expression PredType]
cs   = (LazyBinding -> [Expression PredType])
-> [LazyBinding] -> [Expression PredType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LazyBinding -> [Expression PredType]
mkLB [LazyBinding]
bs
  free :: [(Ident, Int, PredType)]
free = [(Ident, Int, PredType)] -> [(Ident, Int, PredType)]
forall a. Eq a => [a] -> [a]
nub ([(Ident, Int, PredType)] -> [(Ident, Int, PredType)])
-> [(Ident, Int, PredType)] -> [(Ident, Int, PredType)]
forall a b. (a -> b) -> a -> b
$ ((Ident, Int, PredType) -> Bool)
-> [(Ident, Int, PredType)] -> [(Ident, Int, PredType)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Ident, Int, PredType) -> Bool)
-> (Ident, Int, PredType)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Bool
isAnonId (Ident -> Bool)
-> ((Ident, Int, PredType) -> Ident)
-> (Ident, Int, PredType)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ident, Int, PredType) -> Ident
forall a b c. (a, b, c) -> a
fst3) ([(Ident, Int, PredType)] -> [(Ident, Int, PredType)])
-> [(Ident, Int, PredType)] -> [(Ident, Int, PredType)]
forall a b. (a -> b) -> a -> b
$
                 (Pattern PredType -> [(Ident, Int, PredType)])
-> [Pattern PredType] -> [(Ident, Int, PredType)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pattern PredType -> [(Ident, Int, PredType)]
forall t.
(Eq t, Typeable t, ValueType t) =>
Pattern t -> [(Ident, Int, t)]
patternVars ((LazyBinding -> Pattern PredType)
-> [LazyBinding] -> [Pattern PredType]
forall a b. (a -> b) -> [a] -> [b]
map LazyBinding -> Pattern PredType
forall a b. (a, b) -> a
fst [LazyBinding]
bs) [(Ident, Int, PredType)]
-> [(Ident, Int, PredType)] -> [(Ident, Int, PredType)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(Ident, Int, PredType)]
vs

fp2Expr :: Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr :: Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr (LiteralPattern          _ pty :: PredType
pty l :: Literal
l) = (SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo  PredType
pty Literal
l, [])
fp2Expr (NegativePattern         _ pty :: PredType
pty l :: Literal
l) =
  (SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
pty (Literal -> Literal
negateLiteral Literal
l), [])
fp2Expr (VariablePattern         _ pty :: PredType
pty v :: Ident
v) = (PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar PredType
pty Ident
v, [])
fp2Expr (ConstructorPattern  _  pty :: PredType
pty c :: QualIdent
c ts :: [Pattern PredType]
ts) =
  let (ts' :: [Expression PredType]
ts', ess :: [[Expression PredType]]
ess) = [(Expression PredType, [Expression PredType])]
-> ([Expression PredType], [[Expression PredType]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Expression PredType, [Expression PredType])]
 -> ([Expression PredType], [[Expression PredType]]))
-> [(Expression PredType, [Expression PredType])]
-> ([Expression PredType], [[Expression PredType]])
forall a b. (a -> b) -> a -> b
$ (Pattern PredType -> (Expression PredType, [Expression PredType]))
-> [Pattern PredType]
-> [(Expression PredType, [Expression PredType])]
forall a b. (a -> b) -> [a] -> [b]
map Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr [Pattern PredType]
ts
      pty' :: PredType
pty' = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow (PredType -> Type
unpredType PredType
pty) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Pattern PredType -> Type) -> [Pattern PredType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf [Pattern PredType]
ts
  in  (Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
pty' QualIdent
c) [Expression PredType]
ts', [[Expression PredType]] -> [Expression PredType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Expression PredType]]
ess)
fp2Expr (InfixPattern   _ pty :: PredType
pty t1 :: Pattern PredType
t1 op :: QualIdent
op t2 :: Pattern PredType
t2) =
  let (t1' :: Expression PredType
t1', es1 :: [Expression PredType]
es1) = Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr Pattern PredType
t1
      (t2' :: Expression PredType
t2', es2 :: [Expression PredType]
es2) = Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr Pattern PredType
t2
      pty' :: PredType
pty' = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow (PredType -> Type
unpredType PredType
pty) [Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf Pattern PredType
t1, Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf Pattern PredType
t2]
  in  (SpanInfo
-> Expression PredType
-> InfixOp PredType
-> Expression PredType
-> Expression PredType
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
NoSpanInfo Expression PredType
t1' (PredType -> QualIdent -> InfixOp PredType
forall a. a -> QualIdent -> InfixOp a
InfixConstr PredType
pty' QualIdent
op) Expression PredType
t2', [Expression PredType]
es1 [Expression PredType]
-> [Expression PredType] -> [Expression PredType]
forall a. [a] -> [a] -> [a]
++ [Expression PredType]
es2)
fp2Expr (ParenPattern                _ t :: Pattern PredType
t) = (Expression PredType -> Expression PredType)
-> (Expression PredType, [Expression PredType])
-> (Expression PredType, [Expression PredType])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (SpanInfo -> Expression PredType -> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a
Paren SpanInfo
NoSpanInfo) (Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr Pattern PredType
t)
fp2Expr (TuplePattern               _ ts :: [Pattern PredType]
ts) =
  let (ts' :: [Expression PredType]
ts', ess :: [[Expression PredType]]
ess) = [(Expression PredType, [Expression PredType])]
-> ([Expression PredType], [[Expression PredType]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Expression PredType, [Expression PredType])]
 -> ([Expression PredType], [[Expression PredType]]))
-> [(Expression PredType, [Expression PredType])]
-> ([Expression PredType], [[Expression PredType]])
forall a b. (a -> b) -> a -> b
$ (Pattern PredType -> (Expression PredType, [Expression PredType]))
-> [Pattern PredType]
-> [(Expression PredType, [Expression PredType])]
forall a b. (a -> b) -> [a] -> [b]
map Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr [Pattern PredType]
ts
  in  (SpanInfo -> [Expression PredType] -> Expression PredType
forall a. SpanInfo -> [Expression a] -> Expression a
Tuple SpanInfo
NoSpanInfo [Expression PredType]
ts', [[Expression PredType]] -> [Expression PredType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Expression PredType]]
ess)
fp2Expr (ListPattern            _ pty :: PredType
pty ts :: [Pattern PredType]
ts) =
  let (ts' :: [Expression PredType]
ts', ess :: [[Expression PredType]]
ess) = [(Expression PredType, [Expression PredType])]
-> ([Expression PredType], [[Expression PredType]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Expression PredType, [Expression PredType])]
 -> ([Expression PredType], [[Expression PredType]]))
-> [(Expression PredType, [Expression PredType])]
-> ([Expression PredType], [[Expression PredType]])
forall a b. (a -> b) -> a -> b
$ (Pattern PredType -> (Expression PredType, [Expression PredType]))
-> [Pattern PredType]
-> [(Expression PredType, [Expression PredType])]
forall a b. (a -> b) -> [a] -> [b]
map Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr [Pattern PredType]
ts
  in  (SpanInfo
-> PredType -> [Expression PredType] -> Expression PredType
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
NoSpanInfo PredType
pty [Expression PredType]
ts', [[Expression PredType]] -> [Expression PredType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Expression PredType]]
ess)
fp2Expr (FunctionPattern      _ pty :: PredType
pty f :: QualIdent
f ts :: [Pattern PredType]
ts) =
  let (ts' :: [Expression PredType]
ts', ess :: [[Expression PredType]]
ess) = [(Expression PredType, [Expression PredType])]
-> ([Expression PredType], [[Expression PredType]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Expression PredType, [Expression PredType])]
 -> ([Expression PredType], [[Expression PredType]]))
-> [(Expression PredType, [Expression PredType])]
-> ([Expression PredType], [[Expression PredType]])
forall a b. (a -> b) -> a -> b
$ (Pattern PredType -> (Expression PredType, [Expression PredType]))
-> [Pattern PredType]
-> [(Expression PredType, [Expression PredType])]
forall a b. (a -> b) -> [a] -> [b]
map Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr [Pattern PredType]
ts
      pty' :: PredType
pty' = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow (PredType -> Type
unpredType PredType
pty) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Pattern PredType -> Type) -> [Pattern PredType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf [Pattern PredType]
ts
  in  (Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo PredType
pty' QualIdent
f) [Expression PredType]
ts', [[Expression PredType]] -> [Expression PredType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Expression PredType]]
ess)
fp2Expr (InfixFuncPattern _ pty :: PredType
pty t1 :: Pattern PredType
t1 op :: QualIdent
op t2 :: Pattern PredType
t2) =
  let (t1' :: Expression PredType
t1', es1 :: [Expression PredType]
es1) = Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr Pattern PredType
t1
      (t2' :: Expression PredType
t2', es2 :: [Expression PredType]
es2) = Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr Pattern PredType
t2
      pty' :: PredType
pty' = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow (PredType -> Type
unpredType PredType
pty) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ (Pattern PredType -> Type) -> [Pattern PredType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf [Pattern PredType
t1, Pattern PredType
t2]
  in  (SpanInfo
-> Expression PredType
-> InfixOp PredType
-> Expression PredType
-> Expression PredType
forall a.
SpanInfo
-> Expression a -> InfixOp a -> Expression a -> Expression a
InfixApply SpanInfo
NoSpanInfo Expression PredType
t1' (PredType -> QualIdent -> InfixOp PredType
forall a. a -> QualIdent -> InfixOp a
InfixOp PredType
pty' QualIdent
op) Expression PredType
t2', [Expression PredType]
es1 [Expression PredType]
-> [Expression PredType] -> [Expression PredType]
forall a. [a] -> [a] -> [a]
++ [Expression PredType]
es2)
fp2Expr (AsPattern                 _ v :: Ident
v t :: Pattern PredType
t) =
  let (t' :: Expression PredType
t', es :: [Expression PredType]
es) = Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr Pattern PredType
t
      pty :: PredType
pty = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf Pattern PredType
t
  in  (PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar PredType
pty Ident
v, (Expression PredType
t' Expression PredType -> Expression PredType -> Expression PredType
=:<= PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar PredType
pty Ident
v) Expression PredType
-> [Expression PredType] -> [Expression PredType]
forall a. a -> [a] -> [a]
: [Expression PredType]
es)
fp2Expr (RecordPattern        _ pty :: PredType
pty c :: QualIdent
c fs :: [Field (Pattern PredType)]
fs) =
  let (fs' :: [Field (Expression PredType)]
fs', ess :: [[Expression PredType]]
ess) = [(Field (Expression PredType), [Expression PredType])]
-> ([Field (Expression PredType)], [[Expression PredType]])
forall a b. [(a, b)] -> ([a], [b])
unzip [ (SpanInfo
-> QualIdent -> Expression PredType -> Field (Expression PredType)
forall a. SpanInfo -> QualIdent -> a -> Field a
Field SpanInfo
p QualIdent
f Expression PredType
e, [Expression PredType]
es) | Field p :: SpanInfo
p f :: QualIdent
f t :: Pattern PredType
t <- [Field (Pattern PredType)]
fs
                                             , let (e :: Expression PredType
e, es :: [Expression PredType]
es) = Pattern PredType -> (Expression PredType, [Expression PredType])
fp2Expr Pattern PredType
t]
  in  (SpanInfo
-> PredType
-> QualIdent
-> [Field (Expression PredType)]
-> Expression PredType
forall a.
SpanInfo
-> a -> QualIdent -> [Field (Expression a)] -> Expression a
Record SpanInfo
NoSpanInfo PredType
pty QualIdent
c [Field (Expression PredType)]
fs', [[Expression PredType]] -> [Expression PredType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Expression PredType]]
ess)
fp2Expr t :: Pattern PredType
t                               = String -> (Expression PredType, [Expression PredType])
forall a. String -> a
internalError (String -> (Expression PredType, [Expression PredType]))
-> String -> (Expression PredType, [Expression PredType])
forall a b. (a -> b) -> a -> b
$
  "Desugar.fp2Expr: Unexpected constructor term: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pattern PredType -> String
forall a. Show a => a -> String
show Pattern PredType
t

-- -----------------------------------------------------------------------------
-- Desugaring of ordinary patterns
-- -----------------------------------------------------------------------------

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

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

dsLiteralPat :: PredType -> Literal
             -> Either (Pattern PredType) (Pattern PredType)
dsLiteralPat :: PredType -> Literal -> Either (Pattern PredType) (Pattern PredType)
dsLiteralPat pty :: PredType
pty c :: Literal
c@(Char _) = Pattern PredType -> Either (Pattern PredType) (Pattern PredType)
forall a b. b -> Either a b
Right (SpanInfo -> PredType -> Literal -> Pattern PredType
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
NoSpanInfo PredType
pty Literal
c)
dsLiteralPat pty :: PredType
pty (Int i :: Integer
i) =
  Pattern PredType -> Either (Pattern PredType) (Pattern PredType)
forall a b. b -> Either a b
Right (SpanInfo -> PredType -> Literal -> Pattern PredType
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
NoSpanInfo PredType
pty (Type -> Literal
fixLiteral (PredType -> Type
unpredType PredType
pty)))
  where fixLiteral :: Type -> Literal
fixLiteral (TypeConstrained tys :: [Type]
tys _) = Type -> Literal
fixLiteral ([Type] -> Type
forall a. [a] -> a
head [Type]
tys)
        fixLiteral ty :: Type
ty
          | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
floatType = Double -> Literal
Float (Double -> Literal) -> Double -> Literal
forall a b. (a -> b) -> a -> b
$ Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
i
          | Bool
otherwise = Integer -> Literal
Int Integer
i
dsLiteralPat pty :: PredType
pty f :: Literal
f@(Float _) = Pattern PredType -> Either (Pattern PredType) (Pattern PredType)
forall a b. b -> Either a b
Right (SpanInfo -> PredType -> Literal -> Pattern PredType
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
NoSpanInfo PredType
pty Literal
f)
dsLiteralPat pty :: PredType
pty (String cs :: String
cs) =
  Pattern PredType -> Either (Pattern PredType) (Pattern PredType)
forall a b. a -> Either a b
Left (Pattern PredType -> Either (Pattern PredType) (Pattern PredType))
-> Pattern PredType -> Either (Pattern PredType) (Pattern PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> PredType -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> [Pattern a] -> Pattern a
ListPattern SpanInfo
NoSpanInfo PredType
pty ([Pattern PredType] -> Pattern PredType)
-> [Pattern PredType] -> Pattern PredType
forall a b. (a -> b) -> a -> b
$
  (Char -> Pattern PredType) -> String -> [Pattern PredType]
forall a b. (a -> b) -> [a] -> [b]
map (SpanInfo -> PredType -> Literal -> Pattern PredType
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
NoSpanInfo PredType
pty' (Literal -> Pattern PredType)
-> (Char -> Literal) -> Char -> Pattern PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Literal
Char) String
cs
  where pty' :: PredType
pty' = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
elemType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty

dsPat :: SpanInfo -> [Decl PredType] -> Pattern PredType
      -> DsM ([Decl PredType], Pattern PredType)
dsPat :: SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat _ ds :: [Decl PredType]
ds v :: Pattern PredType
v@(VariablePattern       _ _ _) = ([Decl PredType], Pattern PredType)
-> DsM ([Decl PredType], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType]
ds, Pattern PredType
v)
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (LiteralPattern      _ pty :: PredType
pty l :: Literal
l) =
  (Pattern PredType -> DsM ([Decl PredType], Pattern PredType))
-> (Pattern PredType -> DsM ([Decl PredType], Pattern PredType))
-> Either (Pattern PredType) (Pattern PredType)
-> DsM ([Decl PredType], Pattern PredType)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [Decl PredType]
ds) (([Decl PredType], Pattern PredType)
-> DsM ([Decl PredType], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (([Decl PredType], Pattern PredType)
 -> DsM ([Decl PredType], Pattern PredType))
-> (Pattern PredType -> ([Decl PredType], Pattern PredType))
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) [Decl PredType]
ds) (PredType -> Literal -> Either (Pattern PredType) (Pattern PredType)
dsLiteralPat PredType
pty Literal
l)
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (NegativePattern       _ pty :: PredType
pty l :: Literal
l) =
  SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [Decl PredType]
ds (SpanInfo -> PredType -> Literal -> Pattern PredType
forall a. SpanInfo -> a -> Literal -> Pattern a
LiteralPattern SpanInfo
NoSpanInfo PredType
pty (Literal -> Literal
negateLiteral Literal
l))
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (ConstructorPattern _ pty :: PredType
pty c :: QualIdent
c ts :: [Pattern PredType]
ts) =
  ([Pattern PredType] -> Pattern PredType)
-> ([Decl PredType], [Pattern PredType])
-> ([Decl PredType], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
c) (([Decl PredType], [Pattern PredType])
 -> ([Decl PredType], Pattern PredType))
-> StateT
     DesugarState Identity ([Decl PredType], [Pattern PredType])
-> DsM ([Decl PredType], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Decl PredType]
 -> Pattern PredType -> DsM ([Decl PredType], Pattern PredType))
-> [Decl PredType]
-> [Pattern PredType]
-> StateT
     DesugarState Identity ([Decl PredType], [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p) [Decl PredType]
ds [Pattern PredType]
ts
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (InfixPattern   _ pty :: PredType
pty t1 :: Pattern PredType
t1 op :: QualIdent
op t2 :: Pattern PredType
t2) =
  SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [Decl PredType]
ds (SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
op [Pattern PredType
t1, Pattern PredType
t2])
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (ParenPattern              _ t :: Pattern PredType
t) = SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [Decl PredType]
ds Pattern PredType
t
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (RecordPattern      _ pty :: PredType
pty c :: QualIdent
c fs :: [Field (Pattern PredType)]
fs) = do
  ValueEnv
vEnv <- DsM ValueEnv
getValueEnv
  --TODO: Rework
  let (ls :: [QualIdent]
ls, tys :: [Type]
tys) = Type -> QualIdent -> ValueEnv -> ([QualIdent], [Type])
argumentTypes (PredType -> Type
unpredType PredType
pty) QualIdent
c ValueEnv
vEnv
      tsMap :: [(QualIdent, Pattern PredType)]
tsMap = (Field (Pattern PredType) -> (QualIdent, Pattern PredType))
-> [Field (Pattern PredType)] -> [(QualIdent, Pattern PredType)]
forall a b. (a -> b) -> [a] -> [b]
map Field (Pattern PredType) -> (QualIdent, Pattern PredType)
forall a. Field a -> (QualIdent, a)
field2Tuple [Field (Pattern PredType)]
fs
  [Pattern PredType]
anonTs <- (Type -> StateT DesugarState Identity (Pattern PredType))
-> [Type] -> StateT DesugarState Identity [Pattern PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) ((PredType, Ident) -> Pattern PredType)
-> DsM (PredType, Ident)
-> StateT DesugarState Identity (Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (DsM (PredType, Ident)
 -> StateT DesugarState Identity (Pattern PredType))
-> (Type -> DsM (PredType, Ident))
-> Type
-> StateT DesugarState Identity (Pattern PredType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  String -> Type -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#recpat") [Type]
tys
  let maybeTs :: [Maybe (Pattern PredType)]
maybeTs = (QualIdent -> Maybe (Pattern PredType))
-> [QualIdent] -> [Maybe (Pattern PredType)]
forall a b. (a -> b) -> [a] -> [b]
map ((QualIdent
 -> [(QualIdent, Pattern PredType)] -> Maybe (Pattern PredType))
-> [(QualIdent, Pattern PredType)]
-> QualIdent
-> Maybe (Pattern PredType)
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent
-> [(QualIdent, Pattern PredType)] -> Maybe (Pattern PredType)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(QualIdent, Pattern PredType)]
tsMap) [QualIdent]
ls
      ts :: [Pattern PredType]
ts = (Pattern PredType -> Maybe (Pattern PredType) -> Pattern PredType)
-> [Pattern PredType]
-> [Maybe (Pattern PredType)]
-> [Pattern PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern PredType -> Maybe (Pattern PredType) -> Pattern PredType
forall a. a -> Maybe a -> a
fromMaybe [Pattern PredType]
anonTs [Maybe (Pattern PredType)]
maybeTs
  SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [Decl PredType]
ds (SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
c [Pattern PredType]
ts)
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (TuplePattern              _ ts :: [Pattern PredType]
ts) =
  SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [Decl PredType]
ds (SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
pty (Int -> QualIdent
qTupleId (Int -> QualIdent) -> Int -> QualIdent
forall a b. (a -> b) -> a -> b
$ [Pattern PredType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern PredType]
ts) [Pattern PredType]
ts)
  where pty :: PredType
pty = Type -> PredType
predType ([Type] -> Type
tupleType ((Pattern PredType -> Type) -> [Pattern PredType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf [Pattern PredType]
ts))
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (ListPattern           _ pty :: PredType
pty ts :: [Pattern PredType]
ts) =
  ([Pattern PredType] -> Pattern PredType)
-> ([Decl PredType], [Pattern PredType])
-> ([Decl PredType], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Pattern PredType -> Pattern PredType -> Pattern PredType)
-> Pattern PredType -> [Pattern PredType] -> Pattern PredType
forall b. (b -> b -> b) -> b -> [b] -> b
dsList Pattern PredType -> Pattern PredType -> Pattern PredType
cons Pattern PredType
nil) (([Decl PredType], [Pattern PredType])
 -> ([Decl PredType], Pattern PredType))
-> StateT
     DesugarState Identity ([Decl PredType], [Pattern PredType])
-> DsM ([Decl PredType], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Decl PredType]
 -> Pattern PredType -> DsM ([Decl PredType], Pattern PredType))
-> [Decl PredType]
-> [Pattern PredType]
-> StateT
     DesugarState Identity ([Decl PredType], [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p) [Decl PredType]
ds [Pattern PredType]
ts
  where nil :: Pattern PredType
nil = SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
qNilId []
        cons :: Pattern PredType -> Pattern PredType -> Pattern PredType
cons t :: Pattern PredType
t ts' :: Pattern PredType
ts' = SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
qConsId [Pattern PredType
t, Pattern PredType
ts']
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (AsPattern            _ v :: Ident
v t :: Pattern PredType
t) = SpanInfo
-> Ident
-> ([Decl PredType], Pattern PredType)
-> ([Decl PredType], Pattern PredType)
dsAs SpanInfo
p Ident
v (([Decl PredType], Pattern PredType)
 -> ([Decl PredType], Pattern PredType))
-> DsM ([Decl PredType], Pattern PredType)
-> DsM ([Decl PredType], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [Decl PredType]
ds Pattern PredType
t
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (LazyPattern            _ t :: Pattern PredType
t) = SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsLazy SpanInfo
p [Decl PredType]
ds Pattern PredType
t
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (FunctionPattern   _   pty :: PredType
pty f :: QualIdent
f ts :: [Pattern PredType]
ts) =
  ([Pattern PredType] -> Pattern PredType)
-> ([Decl PredType], [Pattern PredType])
-> ([Decl PredType], Pattern PredType)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
f) (([Decl PredType], [Pattern PredType])
 -> ([Decl PredType], Pattern PredType))
-> StateT
     DesugarState Identity ([Decl PredType], [Pattern PredType])
-> DsM ([Decl PredType], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Decl PredType]
 -> Pattern PredType -> DsM ([Decl PredType], Pattern PredType))
-> [Decl PredType]
-> [Pattern PredType]
-> StateT
     DesugarState Identity ([Decl PredType], [Pattern PredType])
forall (m :: * -> *) (p :: * -> *) acc x y.
(Monad m, MonadPlus p) =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, p y)
mapAccumM (SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p) [Decl PredType]
ds [Pattern PredType]
ts
dsPat p :: SpanInfo
p ds :: [Decl PredType]
ds (InfixFuncPattern _ pty :: PredType
pty t1 :: Pattern PredType
t1 f :: QualIdent
f t2 :: Pattern PredType
t2) =
  SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [Decl PredType]
ds (SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
FunctionPattern SpanInfo
NoSpanInfo PredType
pty QualIdent
f [Pattern PredType
t1, Pattern PredType
t2])

dsAs :: SpanInfo -> Ident -> ([Decl PredType], Pattern PredType)
     -> ([Decl PredType], Pattern PredType)
dsAs :: SpanInfo
-> Ident
-> ([Decl PredType], Pattern PredType)
-> ([Decl PredType], Pattern PredType)
dsAs p :: SpanInfo
p v :: Ident
v (ds :: [Decl PredType]
ds, t :: Pattern PredType
t) = case Pattern PredType
t of
  VariablePattern _ pty :: PredType
pty v' :: Ident
v' -> (SpanInfo
-> PredType -> Ident -> Expression PredType -> Decl PredType
forall a. SpanInfo -> a -> Ident -> Expression a -> Decl a
varDecl SpanInfo
p PredType
pty  Ident
v (PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar PredType
pty  Ident
v') Decl PredType -> [Decl PredType] -> [Decl PredType]
forall a. a -> [a] -> [a]
: [Decl PredType]
ds,Pattern PredType
t)
  AsPattern       _  v' :: Ident
v' t' :: Pattern PredType
t' -> (SpanInfo
-> PredType -> Ident -> Expression PredType -> Decl PredType
forall a. SpanInfo -> a -> Ident -> Expression a -> Decl a
varDecl SpanInfo
p PredType
pty' Ident
v (PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar PredType
pty' Ident
v') Decl PredType -> [Decl PredType] -> [Decl PredType]
forall a. a -> [a] -> [a]
: [Decl PredType]
ds,Pattern PredType
t)
    where pty' :: PredType
pty' = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf Pattern PredType
t'
  _                      -> ([Decl PredType]
ds, SpanInfo -> Ident -> Pattern PredType -> Pattern PredType
forall a. SpanInfo -> Ident -> Pattern a -> Pattern a
AsPattern SpanInfo
NoSpanInfo Ident
v Pattern PredType
t)

dsLazy :: SpanInfo -> [Decl PredType] -> Pattern PredType
       -> DsM ([Decl PredType], Pattern PredType)
dsLazy :: SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsLazy p :: SpanInfo
p ds :: [Decl PredType]
ds t :: Pattern PredType
t = case Pattern PredType
t of
  VariablePattern _ _ _ -> ([Decl PredType], Pattern PredType)
-> DsM ([Decl PredType], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Decl PredType]
ds, Pattern PredType
t)
  ParenPattern     _ t' :: Pattern PredType
t' -> SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsLazy SpanInfo
p [Decl PredType]
ds Pattern PredType
t'
  AsPattern      _ v :: Ident
v t' :: Pattern PredType
t' -> SpanInfo
-> Ident
-> ([Decl PredType], Pattern PredType)
-> ([Decl PredType], Pattern PredType)
dsAs SpanInfo
p Ident
v (([Decl PredType], Pattern PredType)
 -> ([Decl PredType], Pattern PredType))
-> DsM ([Decl PredType], Pattern PredType)
-> DsM ([Decl PredType], Pattern PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsLazy SpanInfo
p [Decl PredType]
ds Pattern PredType
t'
  LazyPattern      _ t' :: Pattern PredType
t' -> SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsLazy SpanInfo
p [Decl PredType]
ds Pattern PredType
t'
  _                 -> do
    (pty :: PredType
pty, v' :: Ident
v') <- String -> Pattern PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#lazy" Pattern PredType
t
    ([Decl PredType], Pattern PredType)
-> DsM ([Decl PredType], Pattern PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (SpanInfo
-> Pattern PredType -> Expression PredType -> Decl PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Decl a
patDecl SpanInfo
NoSpanInfo Pattern PredType
t (PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar PredType
pty Ident
v') Decl PredType -> [Decl PredType] -> [Decl PredType]
forall a. a -> [a] -> [a]
: [Decl PredType]
ds,
            SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo PredType
pty Ident
v')

{-
-- -----------------------------------------------------------------------------
-- Desugaring of expressions
-- -----------------------------------------------------------------------------

-- Record construction expressions are transformed into normal
-- constructor applications by rearranging fields in the order of the
-- record's declaration, passing `Prelude.unknown` in place of
-- 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
-- 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.
-}
dsExpr :: SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr :: SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr p :: SpanInfo
p (Literal     _ pty :: PredType
pty l :: Literal
l) =
  (Expression PredType -> DsM (Expression PredType))
-> (Expression PredType -> DsM (Expression PredType))
-> Either (Expression PredType) (Expression PredType)
-> DsM (Expression PredType)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p) Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (PredType
-> Literal -> Either (Expression PredType) (Expression PredType)
dsLiteral PredType
pty Literal
l)
dsExpr _ var :: Expression PredType
var@(Variable _ pty :: PredType
pty v :: QualIdent
v)
  | Ident -> Bool
isAnonId (QualIdent -> Ident
unqualify QualIdent
v)   = Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ Type -> Expression PredType
prelUnknown (Type -> Expression PredType) -> Type -> Expression PredType
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty
  | Bool
otherwise                = Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression PredType
var
dsExpr _ c :: Expression PredType
c@(Constructor _ _ _) = Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return Expression PredType
c
dsExpr p :: SpanInfo
p (Paren           _ e :: Expression PredType
e) = SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e
dsExpr p :: SpanInfo
p (Typed       _ e :: Expression PredType
e qty :: QualTypeExpr
qty) = SpanInfo
-> Expression PredType -> QualTypeExpr -> Expression PredType
forall a. SpanInfo -> Expression a -> QualTypeExpr -> Expression a
Typed SpanInfo
NoSpanInfo
  (Expression PredType -> QualTypeExpr -> Expression PredType)
-> DsM (Expression PredType)
-> StateT
     DesugarState Identity (QualTypeExpr -> Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e StateT DesugarState Identity (QualTypeExpr -> Expression PredType)
-> StateT DesugarState Identity QualTypeExpr
-> DsM (Expression PredType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QualTypeExpr -> StateT DesugarState Identity QualTypeExpr
dsQualTypeExpr QualTypeExpr
qty
dsExpr p :: SpanInfo
p (Record   _ pty :: PredType
pty c :: QualIdent
c fs :: [Field (Expression PredType)]
fs) = do
  ValueEnv
vEnv <- DsM ValueEnv
getValueEnv
  --TODO: Rework
  let (ls :: [QualIdent]
ls, tys :: [Type]
tys) = Type -> QualIdent -> ValueEnv -> ([QualIdent], [Type])
argumentTypes (PredType -> Type
unpredType PredType
pty) QualIdent
c ValueEnv
vEnv
      esMap :: [(QualIdent, Expression PredType)]
esMap = (Field (Expression PredType) -> (QualIdent, Expression PredType))
-> [Field (Expression PredType)]
-> [(QualIdent, Expression PredType)]
forall a b. (a -> b) -> [a] -> [b]
map Field (Expression PredType) -> (QualIdent, Expression PredType)
forall a. Field a -> (QualIdent, a)
field2Tuple [Field (Expression PredType)]
fs
      unknownEs :: [Expression PredType]
unknownEs = (Type -> Expression PredType) -> [Type] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Expression PredType
prelUnknown [Type]
tys
      maybeEs :: [Maybe (Expression PredType)]
maybeEs = (QualIdent -> Maybe (Expression PredType))
-> [QualIdent] -> [Maybe (Expression PredType)]
forall a b. (a -> b) -> [a] -> [b]
map ((QualIdent
 -> [(QualIdent, Expression PredType)]
 -> Maybe (Expression PredType))
-> [(QualIdent, Expression PredType)]
-> QualIdent
-> Maybe (Expression PredType)
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent
-> [(QualIdent, Expression PredType)]
-> Maybe (Expression PredType)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(QualIdent, Expression PredType)]
esMap) [QualIdent]
ls
      es :: [Expression PredType]
es = (Expression PredType
 -> Maybe (Expression PredType) -> Expression PredType)
-> [Expression PredType]
-> [Maybe (Expression PredType)]
-> [Expression PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression PredType
-> Maybe (Expression PredType) -> Expression PredType
forall a. a -> Maybe a -> a
fromMaybe [Expression PredType]
unknownEs [Maybe (Expression PredType)]
maybeEs
  SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (PredType
-> QualIdent
-> [Type]
-> [Expression PredType]
-> Expression PredType
applyConstr PredType
pty QualIdent
c [Type]
tys [Expression PredType]
es)
dsExpr p :: SpanInfo
p (RecordUpdate _ e :: Expression PredType
e fs :: [Field (Expression PredType)]
fs) = do
  [(Pattern PredType, Expression PredType)]
alts  <- QualIdent -> DsM [DataConstr]
constructors QualIdent
tc DsM [DataConstr]
-> ([DataConstr]
    -> StateT
         DesugarState Identity [(Pattern PredType, Expression PredType)])
-> StateT
     DesugarState Identity [(Pattern PredType, Expression PredType)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (DataConstr
 -> StateT
      DesugarState Identity [(Pattern PredType, Expression PredType)])
-> [DataConstr]
-> StateT
     DesugarState Identity [(Pattern PredType, Expression PredType)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM DataConstr
-> StateT
     DesugarState Identity [(Pattern PredType, Expression PredType)]
updateAlt
  SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ CaseType
-> Expression PredType -> [Alt PredType] -> Expression PredType
forall a. CaseType -> Expression a -> [Alt a] -> Expression a
mkCase CaseType
Flex Expression PredType
e (((Pattern PredType, Expression PredType) -> Alt PredType)
-> [(Pattern PredType, Expression PredType)] -> [Alt PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((Pattern PredType -> Expression PredType -> Alt PredType)
-> (Pattern PredType, Expression PredType) -> Alt PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> Pattern PredType -> Expression PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Alt a
caseAlt SpanInfo
p)) [(Pattern PredType, Expression PredType)]
alts)
  where ty :: Type
ty = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e
        pty :: PredType
pty = Type -> PredType
predType Type
ty
        tc :: QualIdent
tc = Type -> QualIdent
rootOfType (Type -> Type
arrowBase Type
ty)
        updateAlt :: DataConstr
-> StateT
     DesugarState Identity [(Pattern PredType, Expression PredType)]
updateAlt (RecordConstr c :: Ident
c ls :: [Ident]
ls _)
          | (QualIdent -> Bool) -> [QualIdent] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (QualIdent -> [QualIdent] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [QualIdent]
qls2) ((Field (Expression PredType) -> QualIdent)
-> [Field (Expression PredType)] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map Field (Expression PredType) -> QualIdent
forall a. Field a -> QualIdent
fieldLabel [Field (Expression PredType)]
fs)= do
            let qc :: QualIdent
qc = QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
tc Ident
c
            ValueEnv
vEnv <- DsM ValueEnv
getValueEnv
            let (qls :: [QualIdent]
qls, tys :: [Type]
tys) = Type -> QualIdent -> ValueEnv -> ([QualIdent], [Type])
argumentTypes Type
ty QualIdent
qc ValueEnv
vEnv
            [(PredType, Ident)]
vs <- (Type -> DsM (PredType, Ident))
-> [Type] -> StateT DesugarState Identity [(PredType, Ident)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Type -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#rec") [Type]
tys
            let pat :: Pattern PredType
pat = PredType -> QualIdent -> [(PredType, Ident)] -> Pattern PredType
forall a. a -> QualIdent -> [(a, Ident)] -> Pattern a
constrPattern PredType
pty QualIdent
qc [(PredType, Ident)]
vs
                esMap :: [(QualIdent, Expression PredType)]
esMap = (Field (Expression PredType) -> (QualIdent, Expression PredType))
-> [Field (Expression PredType)]
-> [(QualIdent, Expression PredType)]
forall a b. (a -> b) -> [a] -> [b]
map Field (Expression PredType) -> (QualIdent, Expression PredType)
forall a. Field a -> (QualIdent, a)
field2Tuple [Field (Expression PredType)]
fs
                originalEs :: [Expression PredType]
originalEs = ((PredType, Ident) -> Expression PredType)
-> [(PredType, Ident)] -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar) [(PredType, Ident)]
vs
                maybeEs :: [Maybe (Expression PredType)]
maybeEs = (QualIdent -> Maybe (Expression PredType))
-> [QualIdent] -> [Maybe (Expression PredType)]
forall a b. (a -> b) -> [a] -> [b]
map ((QualIdent
 -> [(QualIdent, Expression PredType)]
 -> Maybe (Expression PredType))
-> [(QualIdent, Expression PredType)]
-> QualIdent
-> Maybe (Expression PredType)
forall a b c. (a -> b -> c) -> b -> a -> c
flip QualIdent
-> [(QualIdent, Expression PredType)]
-> Maybe (Expression PredType)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(QualIdent, Expression PredType)]
esMap) [QualIdent]
qls
                es :: [Expression PredType]
es = (Expression PredType
 -> Maybe (Expression PredType) -> Expression PredType)
-> [Expression PredType]
-> [Maybe (Expression PredType)]
-> [Expression PredType]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expression PredType
-> Maybe (Expression PredType) -> Expression PredType
forall a. a -> Maybe a -> a
fromMaybe [Expression PredType]
originalEs [Maybe (Expression PredType)]
maybeEs
            [(Pattern PredType, Expression PredType)]
-> StateT
     DesugarState Identity [(Pattern PredType, Expression PredType)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Pattern PredType
pat, PredType
-> QualIdent
-> [Type]
-> [Expression PredType]
-> Expression PredType
applyConstr PredType
pty QualIdent
qc [Type]
tys [Expression PredType]
es)]
          where qls2 :: [QualIdent]
qls2 = (Ident -> QualIdent) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
tc) [Ident]
ls
        updateAlt _ = [(Pattern PredType, Expression PredType)]
-> StateT
     DesugarState Identity [(Pattern PredType, Expression PredType)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
dsExpr p :: SpanInfo
p (Tuple      _ es :: [Expression PredType]
es) =
  Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
pty (QualIdent -> Expression PredType)
-> QualIdent -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Int -> QualIdent
qTupleId (Int -> QualIdent) -> Int -> QualIdent
forall a b. (a -> b) -> a -> b
$ [Expression PredType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression PredType]
es)
  ([Expression PredType] -> Expression PredType)
-> StateT DesugarState Identity [Expression PredType]
-> DsM (Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression PredType -> DsM (Expression PredType))
-> [Expression PredType]
-> StateT DesugarState Identity [Expression PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p) [Expression PredType]
es
  where pty :: PredType
pty = Type -> PredType
predType ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow ([Type] -> Type
tupleType [Type]
tys) [Type]
tys)
        tys :: [Type]
tys = (Expression PredType -> Type) -> [Expression PredType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf [Expression PredType]
es
dsExpr p :: SpanInfo
p (List   _ pty :: PredType
pty es :: [Expression PredType]
es) = (Expression PredType -> Expression PredType -> Expression PredType)
-> Expression PredType
-> [Expression PredType]
-> Expression PredType
forall b. (b -> b -> b) -> b -> [b] -> b
dsList Expression PredType -> Expression PredType -> Expression PredType
cons Expression PredType
nil ([Expression PredType] -> Expression PredType)
-> StateT DesugarState Identity [Expression PredType]
-> DsM (Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression PredType -> DsM (Expression PredType))
-> [Expression PredType]
-> StateT DesugarState Identity [Expression PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p) [Expression PredType]
es
  where nil :: Expression PredType
nil = SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo PredType
pty QualIdent
qNilId
        cons :: Expression PredType -> Expression PredType -> Expression PredType
cons = (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo) (Expression PredType -> Expression PredType -> Expression PredType)
-> (Expression PredType -> Expression PredType)
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo)
          (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo
            (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
consType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
elemType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty) QualIdent
qConsId)
dsExpr p :: SpanInfo
p (ListCompr          _ e :: Expression PredType
e qs :: [Statement PredType]
qs) = SpanInfo
-> Expression PredType
-> [Statement PredType]
-> DsM (Expression PredType)
dsListComp SpanInfo
p Expression PredType
e [Statement PredType]
qs
dsExpr p :: SpanInfo
p (EnumFrom              _ e :: Expression PredType
e) =
  SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Type -> Expression PredType
prelEnumFrom (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e)) (Expression PredType -> Expression PredType)
-> DsM (Expression PredType) -> DsM (Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e
dsExpr p :: SpanInfo
p (EnumFromThen      _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2) =
  Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Expression PredType
prelEnumFromThen (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1)) ([Expression PredType] -> Expression PredType)
-> StateT DesugarState Identity [Expression PredType]
-> DsM (Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression PredType -> DsM (Expression PredType))
-> [Expression PredType]
-> StateT DesugarState Identity [Expression PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p) [Expression PredType
e1, Expression PredType
e2]
dsExpr p :: SpanInfo
p (EnumFromTo        _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2) = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Expression PredType
prelEnumFromTo (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1))
                                    ([Expression PredType] -> Expression PredType)
-> StateT DesugarState Identity [Expression PredType]
-> DsM (Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression PredType -> DsM (Expression PredType))
-> [Expression PredType]
-> StateT DesugarState Identity [Expression PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p) [Expression PredType
e1, Expression PredType
e2]
dsExpr p :: SpanInfo
p (EnumFromThenTo _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 e3 :: Expression PredType
e3) = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Expression PredType
prelEnumFromThenTo (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1))
                                    ([Expression PredType] -> Expression PredType)
-> StateT DesugarState Identity [Expression PredType]
-> DsM (Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression PredType -> DsM (Expression PredType))
-> [Expression PredType]
-> StateT DesugarState Identity [Expression PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p) [Expression PredType
e1, Expression PredType
e2, Expression PredType
e3]
dsExpr p :: SpanInfo
p (UnaryMinus            _ e :: Expression PredType
e) = do
  Expression PredType
e' <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e
  Bool
negativeLitsEnabled <- DsM Bool
checkNegativeLitsExtension
  Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ case Expression PredType
e' of
    Literal _ pty :: PredType
pty l :: Literal
l | Bool
negativeLitsEnabled ->
      SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
pty (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Literal -> Literal
negateLiteral Literal
l
    _                                     ->
      SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Type -> Expression PredType
prelNegate (Type -> Expression PredType) -> Type -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e') Expression PredType
e'
dsExpr p :: SpanInfo
p (Apply _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2) = SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Expression PredType -> Expression PredType -> Expression PredType)
-> DsM (Expression PredType)
-> StateT
     DesugarState Identity (Expression PredType -> Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e1 StateT
  DesugarState Identity (Expression PredType -> Expression PredType)
-> DsM (Expression PredType) -> DsM (Expression PredType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e2
dsExpr p :: SpanInfo
p (InfixApply _ e1 :: Expression PredType
e1 op :: InfixOp PredType
op e2 :: Expression PredType
e2) = do
  Expression PredType
op' <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (InfixOp PredType -> Expression PredType
forall a. InfixOp a -> Expression a
infixOp InfixOp PredType
op)
  Expression PredType
e1' <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e1
  Expression PredType
e2' <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e2
  Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply Expression PredType
op' [Expression PredType
e1', Expression PredType
e2']
dsExpr p :: SpanInfo
p (LeftSection  _ e :: Expression PredType
e op :: InfixOp PredType
op) =
  SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Expression PredType -> Expression PredType -> Expression PredType)
-> DsM (Expression PredType)
-> StateT
     DesugarState Identity (Expression PredType -> Expression PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (InfixOp PredType -> Expression PredType
forall a. InfixOp a -> Expression a
infixOp InfixOp PredType
op) StateT
  DesugarState Identity (Expression PredType -> Expression PredType)
-> DsM (Expression PredType) -> DsM (Expression PredType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e
dsExpr p :: SpanInfo
p (RightSection _ op :: InfixOp PredType
op e :: Expression PredType
e) = do
  Expression PredType
op' <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (InfixOp PredType -> Expression PredType
forall a. InfixOp a -> Expression a
infixOp InfixOp PredType
op)
  Expression PredType
e'  <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e
  Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Type -> Type -> Expression PredType
prelFlip Type
ty1 Type
ty2 Type
ty3) [Expression PredType
op', Expression PredType
e']
  where TypeArrow ty1 :: Type
ty1 (TypeArrow ty2 :: Type
ty2 ty3 :: Type
ty3) = Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf (InfixOp PredType -> Expression PredType
forall a. InfixOp a -> Expression a
infixOp InfixOp PredType
op)
dsExpr p :: SpanInfo
p expr :: Expression PredType
expr@(Lambda _ ts :: [Pattern PredType]
ts e :: Expression PredType
e) = do
  (pty :: PredType
pty, f :: Ident
f) <- String -> Expression PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#lambda" Expression PredType
expr
  SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ [Decl PredType] -> Expression PredType -> Expression PredType
forall a. [Decl a] -> Expression a -> Expression a
mkLet [SpanInfo
-> PredType
-> Ident
-> [Pattern PredType]
-> Expression PredType
-> Decl PredType
forall a.
SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a
funDecl SpanInfo
p PredType
pty Ident
f [Pattern PredType]
ts Expression PredType
e] (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$ PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar PredType
pty Ident
f
dsExpr p :: SpanInfo
p (Let _ _ ds :: [Decl PredType]
ds e :: Expression PredType
e) = do
  [Decl PredType]
ds' <- [Decl PredType] -> State DesugarState [Decl PredType]
dsDeclGroup [Decl PredType]
ds
  Expression PredType
e'  <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e
  Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ [Decl PredType] -> Expression PredType -> Expression PredType
forall a. [Decl a] -> Expression a -> Expression a
mkLet [Decl PredType]
ds' Expression PredType
e'
dsExpr p :: SpanInfo
p (Do            _ _ sts :: [Statement PredType]
sts e :: Expression PredType
e) = [Statement PredType]
-> Expression PredType -> DsM (Expression PredType)
dsDo [Statement PredType]
sts Expression PredType
e DsM (Expression PredType)
-> (Expression PredType -> DsM (Expression PredType))
-> DsM (Expression PredType)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p
dsExpr p :: SpanInfo
p (IfThenElse _ e1 :: Expression PredType
e1 e2 :: Expression PredType
e2 e3 :: Expression PredType
e3) = do
  Expression PredType
e1' <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e1
  Expression PredType
e2' <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e2
  Expression PredType
e3' <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e3
  Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ CaseType
-> Expression PredType -> [Alt PredType] -> Expression PredType
forall a. CaseType -> Expression a -> [Alt a] -> Expression a
mkCase CaseType
Rigid Expression PredType
e1'
             [SpanInfo -> Pattern PredType -> Expression PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Alt a
caseAlt SpanInfo
p Pattern PredType
truePat Expression PredType
e2', SpanInfo -> Pattern PredType -> Expression PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Alt a
caseAlt SpanInfo
p Pattern PredType
falsePat Expression PredType
e3']
dsExpr p :: SpanInfo
p (Case _ _ ct :: CaseType
ct e :: Expression PredType
e alts :: [Alt PredType]
alts) = SpanInfo
-> CaseType
-> Expression PredType
-> [Alt PredType]
-> DsM (Expression PredType)
dsCase SpanInfo
p CaseType
ct Expression PredType
e [Alt PredType]
alts

-- 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 -> StateT DesugarState Identity QualTypeExpr
dsQualTypeExpr (QualTypeExpr _ cx :: Context
cx ty :: TypeExpr
ty) =
  SpanInfo -> Context -> TypeExpr -> QualTypeExpr
QualTypeExpr SpanInfo
NoSpanInfo Context
cx (TypeExpr -> QualTypeExpr)
-> StateT DesugarState Identity TypeExpr
-> StateT DesugarState Identity QualTypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExpr -> StateT DesugarState Identity TypeExpr
dsTypeExpr TypeExpr
ty

dsTypeExpr :: TypeExpr -> DsM TypeExpr
dsTypeExpr :: TypeExpr -> StateT DesugarState Identity TypeExpr
dsTypeExpr ty :: TypeExpr
ty = do
  ModuleIdent
m <- DsM ModuleIdent
getModuleIdent
  TCEnv
tcEnv <- DsM TCEnv
getTyConsEnv
  let tvs :: [Ident]
tvs = TypeExpr -> [Ident]
typeVariables TypeExpr
ty
  TypeExpr -> StateT DesugarState Identity TypeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeExpr -> StateT DesugarState Identity TypeExpr)
-> TypeExpr -> StateT DesugarState Identity TypeExpr
forall a b. (a -> b) -> a -> b
$ [Ident] -> Type -> TypeExpr
fromType [Ident]
tvs (Type -> TypeExpr) -> Type -> TypeExpr
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> TCEnv -> Type -> Type
expandType ModuleIdent
m TCEnv
tcEnv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Ident] -> TypeExpr -> Type
toType [Ident]
tvs TypeExpr
ty

-- -----------------------------------------------------------------------------
-- Desugaring of case expressions
-- -----------------------------------------------------------------------------

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

dsCase :: SpanInfo -> CaseType -> Expression PredType -> [Alt PredType]
       -> DsM (Expression PredType)
dsCase :: SpanInfo
-> CaseType
-> Expression PredType
-> [Alt PredType]
-> DsM (Expression PredType)
dsCase p :: SpanInfo
p ct :: CaseType
ct e :: Expression PredType
e alts :: [Alt PredType]
alts
  | [Alt PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt PredType]
alts = String -> DsM (Expression PredType)
forall a. String -> a
internalError "Desugar.dsCase: empty list of alternatives"
  | Bool
otherwise = do
    ModuleIdent
m  <- DsM ModuleIdent
getModuleIdent
    Expression PredType
e' <- SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p Expression PredType
e
    (PredType, Ident)
v  <- String -> Expression PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#case" Expression PredType
e
    [Alt PredType]
alts'  <- (Alt PredType -> StateT DesugarState Identity (Alt PredType))
-> [Alt PredType] -> StateT DesugarState Identity [Alt PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt PredType -> StateT DesugarState Identity (Alt PredType)
dsAltLhs [Alt PredType]
alts
    [Alt PredType]
alts'' <- ([Alt PredType] -> StateT DesugarState Identity (Alt PredType))
-> [[Alt PredType]] -> StateT DesugarState Identity [Alt PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((PredType, Ident)
-> CaseType
-> [Alt PredType]
-> StateT DesugarState Identity (Alt PredType)
expandAlt (PredType, Ident)
v CaseType
ct) ([[Alt PredType]] -> [[Alt PredType]]
forall a. [a] -> [a]
init ([Alt PredType] -> [[Alt PredType]]
forall a. [a] -> [[a]]
tails [Alt PredType]
alts')) StateT DesugarState Identity [Alt PredType]
-> ([Alt PredType] -> StateT DesugarState Identity [Alt PredType])
-> StateT DesugarState Identity [Alt PredType]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Alt PredType -> StateT DesugarState Identity (Alt PredType))
-> [Alt PredType] -> StateT DesugarState Identity [Alt PredType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt PredType -> StateT DesugarState Identity (Alt PredType)
dsAltRhs
    Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleIdent
-> (PredType, Ident)
-> Expression PredType
-> [Alt PredType]
-> Expression PredType
forall a.
ModuleIdent
-> (a, Ident) -> Expression a -> [Alt a] -> Expression a
mkMyCase ModuleIdent
m (PredType, Ident)
v Expression PredType
e' [Alt PredType]
alts'')
  where
  mkMyCase :: ModuleIdent
-> (a, Ident) -> Expression a -> [Alt a] -> Expression a
mkMyCase m :: ModuleIdent
m (pty :: a
pty, v :: Ident
v) e' :: Expression a
e' bs :: [Alt a]
bs
    | Ident
v Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ModuleIdent -> [Alt a] -> [Ident]
forall e. QualExpr e => ModuleIdent -> e -> [Ident]
qfv ModuleIdent
m [Alt a]
bs = [Decl a] -> Expression a -> Expression a
forall a. [Decl a] -> Expression a -> Expression a
mkLet [SpanInfo -> a -> Ident -> Expression a -> Decl a
forall a. SpanInfo -> a -> Ident -> Expression a -> Decl a
varDecl SpanInfo
p a
pty Ident
v Expression a
e']
                          (CaseType -> Expression a -> [Alt a] -> Expression a
forall a. CaseType -> Expression a -> [Alt a] -> Expression a
mkCase CaseType
ct (a -> Ident -> Expression a
forall a. a -> Ident -> Expression a
mkVar a
pty Ident
v) [Alt a]
bs)
    | Bool
otherwise         = CaseType -> Expression a -> [Alt a] -> Expression a
forall a. CaseType -> Expression a -> [Alt a] -> Expression a
mkCase CaseType
ct Expression a
e' [Alt a]
bs

dsAltLhs :: Alt PredType -> DsM (Alt PredType)
dsAltLhs :: Alt PredType -> StateT DesugarState Identity (Alt PredType)
dsAltLhs (Alt p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs) = do
  (ds' :: [Decl PredType]
ds', t' :: Pattern PredType
t') <- SpanInfo
-> [Decl PredType]
-> Pattern PredType
-> DsM ([Decl PredType], Pattern PredType)
dsPat SpanInfo
p [] Pattern PredType
t
  Alt PredType -> StateT DesugarState Identity (Alt PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Alt PredType -> StateT DesugarState Identity (Alt PredType))
-> Alt PredType -> StateT DesugarState Identity (Alt PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> Pattern PredType -> Rhs PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern PredType
t' ([Decl PredType] -> Rhs PredType -> Rhs PredType
addDecls [Decl PredType]
ds' Rhs PredType
rhs)

dsAltRhs :: Alt PredType -> DsM (Alt PredType)
dsAltRhs :: Alt PredType -> StateT DesugarState Identity (Alt PredType)
dsAltRhs (Alt p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs) = SpanInfo -> Pattern PredType -> Rhs PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Rhs a -> Alt a
Alt SpanInfo
p Pattern PredType
t (Rhs PredType -> Alt PredType)
-> StateT DesugarState Identity (Rhs PredType)
-> StateT DesugarState Identity (Alt PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression PredType -> Expression PredType)
-> Rhs PredType -> StateT DesugarState Identity (Rhs PredType)
dsRhs Expression PredType -> Expression PredType
forall a. a -> a
id Rhs PredType
rhs

expandAlt :: (PredType, Ident) -> CaseType -> [Alt PredType]
          -> DsM (Alt PredType)
expandAlt :: (PredType, Ident)
-> CaseType
-> [Alt PredType]
-> StateT DesugarState Identity (Alt PredType)
expandAlt _ _  []                   = String -> StateT DesugarState Identity (Alt PredType)
forall a. HasCallStack => String -> a
error "Desugar.expandAlt: empty list"
expandAlt v :: (PredType, Ident)
v ct :: CaseType
ct (Alt p :: SpanInfo
p t :: Pattern PredType
t rhs :: Rhs PredType
rhs : alts :: [Alt PredType]
alts) = SpanInfo -> Pattern PredType -> Expression PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Alt a
caseAlt SpanInfo
p Pattern PredType
t (Expression PredType -> Alt PredType)
-> DsM (Expression PredType)
-> StateT DesugarState Identity (Alt PredType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression PredType
-> (Expression PredType -> Expression PredType)
-> Rhs PredType
-> DsM (Expression PredType)
expandRhs Expression PredType
e0 Expression PredType -> Expression PredType
forall a. a -> a
id Rhs PredType
rhs
  where
  e0 :: Expression PredType
e0 | CaseType
ct CaseType -> CaseType -> Bool
forall a. Eq a => a -> a -> Bool
== CaseType
Flex Bool -> Bool -> Bool
|| [Alt PredType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt PredType]
compAlts = Type -> Expression PredType
prelFailed (Rhs PredType -> Type
forall a. Typeable a => a -> Type
typeOf Rhs PredType
rhs)
     | Bool
otherwise = CaseType
-> Expression PredType -> [Alt PredType] -> Expression PredType
forall a. CaseType -> Expression a -> [Alt a] -> Expression a
mkCase CaseType
ct ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
v) [Alt PredType]
compAlts
  compAlts :: [Alt PredType]
compAlts = (Alt PredType -> Bool) -> [Alt PredType] -> [Alt PredType]
forall a. (a -> Bool) -> [a] -> [a]
filter (Pattern PredType -> Pattern PredType -> Bool
forall a. Pattern a -> Pattern a -> Bool
isCompatible Pattern PredType
t (Pattern PredType -> Bool)
-> (Alt PredType -> Pattern PredType) -> Alt PredType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt PredType -> Pattern PredType
forall a. Alt a -> Pattern a
altPattern) [Alt PredType]
alts
  altPattern :: Alt a -> Pattern a
altPattern (Alt _ t1 :: Pattern a
t1 _) = Pattern a
t1

isCompatible :: Pattern a -> Pattern a -> Bool
isCompatible :: Pattern a -> Pattern a -> Bool
isCompatible (VariablePattern _ _ _) _ = Bool
True
isCompatible _ (VariablePattern _ _ _) = Bool
True
isCompatible (AsPattern _ _ t1 :: Pattern a
t1) t2 :: Pattern a
t2 = Pattern a -> Pattern a -> Bool
forall a. Pattern a -> Pattern a -> Bool
isCompatible Pattern a
t1 Pattern a
t2
isCompatible t1 :: Pattern a
t1 (AsPattern _ _ t2 :: Pattern a
t2) = Pattern a -> Pattern a -> Bool
forall a. Pattern a -> Pattern a -> Bool
isCompatible Pattern a
t1 Pattern a
t2
isCompatible (ConstructorPattern _ _ c1 :: QualIdent
c1 ts1 :: [Pattern a]
ts1) (ConstructorPattern _ _ c2 :: QualIdent
c2 ts2 :: [Pattern a]
ts2)
  = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((QualIdent
c1 QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
c2) Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: (Pattern a -> Pattern a -> Bool)
-> [Pattern a] -> [Pattern a] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Pattern a -> Pattern a -> Bool
forall a. Pattern a -> Pattern a -> Bool
isCompatible [Pattern a]
ts1 [Pattern a]
ts2)
isCompatible (LiteralPattern _ _ l1 :: Literal
l1) (LiteralPattern _ _ l2 :: Literal
l2) = Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l2
isCompatible _ _ = Bool
False

-- -----------------------------------------------------------------------------
-- Desugaring of do-Notation
-- -----------------------------------------------------------------------------

-- 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' >>= \v -> case v of
--                                           p -> dsDo(ss, e)
--                                           _ -> fail "..."`
-- `dsDo(let ds ; ss, e)` -> `let ds in    dsDo(ss, e)`
dsDo :: [Statement PredType] -> Expression PredType -> DsM (Expression PredType)
dsDo :: [Statement PredType]
-> Expression PredType -> DsM (Expression PredType)
dsDo sts :: [Statement PredType]
sts e :: Expression PredType
e = (Statement PredType
 -> Expression PredType -> DsM (Expression PredType))
-> Expression PredType
-> [Statement PredType]
-> DsM (Expression PredType)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Statement PredType
-> Expression PredType -> DsM (Expression PredType)
dsStmt Expression PredType
e [Statement PredType]
sts

dsStmt :: Statement PredType -> Expression PredType -> DsM (Expression PredType)
dsStmt :: Statement PredType
-> Expression PredType -> DsM (Expression PredType)
dsStmt (StmtExpr   _ e1 :: Expression PredType
e1) e' :: Expression PredType
e' =
  Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Type -> Expression PredType
prelBind_ (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1) (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e')) [Expression PredType
e1, Expression PredType
e']
dsStmt (StmtBind _ t :: Pattern PredType
t e1 :: Expression PredType
e1) e' :: Expression PredType
e' = do
  (PredType, Ident)
v <- String -> Pattern PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#var" Pattern PredType
t
  Bool
failable <- Pattern PredType -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind Pattern PredType
t
  let func :: Expression PredType
func = [Pattern PredType] -> Expression PredType -> Expression PredType
forall a. [Pattern a] -> Expression a -> Expression a
mkLambda [(PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) (PredType, Ident)
v] (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
               CaseType
-> Expression PredType -> [Alt PredType] -> Expression PredType
forall a. CaseType -> Expression a -> [Alt a] -> Expression a
mkCase CaseType
Rigid ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
v) ([Alt PredType] -> Expression PredType)
-> [Alt PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$
                 SpanInfo -> Pattern PredType -> Expression PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Alt a
caseAlt SpanInfo
NoSpanInfo Pattern PredType
t Expression PredType
e' Alt PredType -> [Alt PredType] -> [Alt PredType]
forall a. a -> [a] -> [a]
:
                   if Bool
failable
                     then [SpanInfo -> Pattern PredType -> Expression PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Alt a
caseAlt SpanInfo
NoSpanInfo
                                   ((PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) (PredType, Ident)
v)
                                   (Type -> Expression PredType
failedPatternMatch (Type -> Expression PredType) -> Type -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e')]
                     else []
  Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Type -> Type -> Expression PredType
prelBind (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1) (Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf Pattern PredType
t) (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e')) [Expression PredType
e1, Expression PredType
func]
  where failedPatternMatch :: Type -> Expression PredType
failedPatternMatch ty :: Type
ty =
          Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Expression PredType
prelFail Type
ty)
            [SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
predStringType (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ String -> Literal
String "Pattern match failed!"]
dsStmt (StmtDecl   _ _ ds :: [Decl PredType]
ds) e' :: Expression PredType
e' = Expression PredType -> DsM (Expression PredType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression PredType -> DsM (Expression PredType))
-> Expression PredType -> DsM (Expression PredType)
forall a b. (a -> b) -> a -> b
$ [Decl PredType] -> Expression PredType -> Expression PredType
forall a. [Decl a] -> Expression a -> Expression a
mkLet [Decl PredType]
ds Expression PredType
e'

checkFailableBind :: Pattern a -> DsM Bool
checkFailableBind :: Pattern a -> DsM Bool
checkFailableBind (ConstructorPattern _ _ idt :: QualIdent
idt ps :: [Pattern a]
ps   ) = do
  TCEnv
tcEnv <- DsM TCEnv
getTyConsEnv
  case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
idt TCEnv
tcEnv of
    [RenamingType _ _ _ ] -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> StateT DesugarState Identity [Bool] -> DsM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> DsM Bool)
-> [Pattern a] -> StateT DesugarState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind [Pattern a]
ps -- or [] == False
    [DataType     _ _ cs :: [DataConstr]
cs]
      | [DataConstr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataConstr]
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1    -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> StateT DesugarState Identity [Bool] -> DsM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> DsM Bool)
-> [Pattern a] -> StateT DesugarState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind [Pattern a]
ps
      | Bool
otherwise         -> Bool -> DsM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    _                     -> Bool -> DsM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkFailableBind (InfixPattern       _ _ p1 :: Pattern a
p1 idt :: QualIdent
idt p2 :: Pattern a
p2) = do
  TCEnv
tcEnv <- DsM TCEnv
getTyConsEnv
  case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
idt TCEnv
tcEnv of
    [RenamingType _ _ _ ] -> Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> DsM Bool -> StateT DesugarState Identity (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind Pattern a
p1
                                  StateT DesugarState Identity (Bool -> Bool) -> DsM Bool -> DsM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind Pattern a
p2
    [DataType     _ _ cs :: [DataConstr]
cs]
      | [DataConstr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataConstr]
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1    -> Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> DsM Bool -> StateT DesugarState Identity (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind Pattern a
p1
                                  StateT DesugarState Identity (Bool -> Bool) -> DsM Bool -> DsM Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind Pattern a
p2
      | Bool
otherwise         -> Bool -> DsM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    _                     -> Bool -> DsM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
checkFailableBind (RecordPattern      _ _ idt :: QualIdent
idt fs :: [Field (Pattern a)]
fs   ) = do
  TCEnv
tcEnv <- DsM TCEnv
getTyConsEnv
  case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
idt TCEnv
tcEnv of
    [RenamingType _ _ _ ] -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> StateT DesugarState Identity [Bool] -> DsM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field (Pattern a) -> DsM Bool)
-> [Field (Pattern a)] -> StateT DesugarState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind (Pattern a -> DsM Bool)
-> (Field (Pattern a) -> Pattern a)
-> Field (Pattern a)
-> DsM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field (Pattern a) -> Pattern a
forall a. Field a -> a
fieldContent) [Field (Pattern a)]
fs
    [DataType     _ _ cs :: [DataConstr]
cs]
      | [DataConstr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataConstr]
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1    -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> StateT DesugarState Identity [Bool] -> DsM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Field (Pattern a) -> DsM Bool)
-> [Field (Pattern a)] -> StateT DesugarState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind (Pattern a -> DsM Bool)
-> (Field (Pattern a) -> Pattern a)
-> Field (Pattern a)
-> DsM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field (Pattern a) -> Pattern a
forall a. Field a -> a
fieldContent) [Field (Pattern a)]
fs
      | Bool
otherwise         -> Bool -> DsM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    _                     -> Bool -> DsM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  where fieldContent :: Field a -> a
fieldContent (Field _ _ c :: a
c) = a
c
checkFailableBind (TuplePattern       _       ps :: [Pattern a]
ps   ) =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> StateT DesugarState Identity [Bool] -> DsM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern a -> DsM Bool)
-> [Pattern a] -> StateT DesugarState Identity [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind [Pattern a]
ps
checkFailableBind (AsPattern          _   _   p :: Pattern a
p    ) = Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind Pattern a
p
checkFailableBind (ParenPattern       _       p :: Pattern a
p    ) = Pattern a -> DsM Bool
forall a. Pattern a -> DsM Bool
checkFailableBind Pattern a
p
checkFailableBind (LazyPattern        _       _    ) = Bool -> DsM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
checkFailableBind (VariablePattern    _ _ _        ) = Bool -> DsM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
checkFailableBind _                                  = Bool -> DsM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
-- -----------------------------------------------------------------------------
-- Desugaring of List Comprehensions
-- -----------------------------------------------------------------------------

-- 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.
-- TODO: Unfortunately, this is incorrect.

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

dsListComp :: SpanInfo -> Expression PredType -> [Statement PredType]
           -> DsM (Expression PredType)
dsListComp :: SpanInfo
-> Expression PredType
-> [Statement PredType]
-> DsM (Expression PredType)
dsListComp p :: SpanInfo
p e :: Expression PredType
e []     =
  SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (SpanInfo
-> PredType -> [Expression PredType] -> Expression PredType
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
NoSpanInfo (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
listType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e) [Expression PredType
e])
dsListComp p :: SpanInfo
p e :: Expression PredType
e (q :: Statement PredType
q:qs :: [Statement PredType]
qs) = SpanInfo
-> Statement PredType
-> Expression PredType
-> DsM (Expression PredType)
dsQual SpanInfo
p Statement PredType
q (SpanInfo
-> Expression PredType
-> [Statement PredType]
-> Expression PredType
forall a. SpanInfo -> Expression a -> [Statement a] -> Expression a
ListCompr SpanInfo
NoSpanInfo Expression PredType
e [Statement PredType]
qs)

dsQual :: SpanInfo -> Statement PredType -> Expression PredType
       -> DsM (Expression PredType)
dsQual :: SpanInfo
-> Statement PredType
-> Expression PredType
-> DsM (Expression PredType)
dsQual p :: SpanInfo
p (StmtExpr   _ b :: Expression PredType
b) e :: Expression PredType
e =
  SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a.
SpanInfo
-> Expression a -> Expression a -> Expression a -> Expression a
IfThenElse SpanInfo
NoSpanInfo Expression PredType
b Expression PredType
e (SpanInfo
-> PredType -> [Expression PredType] -> Expression PredType
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
NoSpanInfo (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e) []))
dsQual p :: SpanInfo
p (StmtDecl _ _ ds :: [Decl PredType]
ds) e :: Expression PredType
e = SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p ([Decl PredType] -> Expression PredType -> Expression PredType
forall a. [Decl a] -> Expression a -> Expression a
mkLet [Decl PredType]
ds Expression PredType
e)
dsQual p :: SpanInfo
p (StmtBind _ t :: Pattern PredType
t l :: Expression PredType
l) e :: Expression PredType
e
  | Pattern PredType -> Bool
forall a. Pattern a -> Bool
isVariablePattern Pattern PredType
t = SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (Pattern PredType
-> Expression PredType
-> Expression PredType
-> Expression PredType
qualExpr Pattern PredType
t Expression PredType
e Expression PredType
l)
  | Bool
otherwise = do
    (PredType, Ident)
v <- String -> Pattern PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#var" Pattern PredType
t
    (PredType, Ident)
l' <- String -> Expression PredType -> DsM (PredType, Ident)
forall t. Typeable t => String -> t -> DsM (PredType, Ident)
freshVar "_#var" Expression PredType
e
    SpanInfo -> Expression PredType -> DsM (Expression PredType)
dsExpr SpanInfo
p (Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Type -> Expression PredType
prelFoldr (Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf Pattern PredType
t) (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e))
      [(PredType, Ident)
-> (PredType, Ident) -> Expression PredType -> Expression PredType
foldFunct (PredType, Ident)
v (PredType, Ident)
l' Expression PredType
e, SpanInfo
-> PredType -> [Expression PredType] -> Expression PredType
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
NoSpanInfo (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e) [], Expression PredType
l])
  where
  qualExpr :: Pattern PredType
-> Expression PredType
-> Expression PredType
-> Expression PredType
qualExpr v :: Pattern PredType
v (ListCompr NoSpanInfo e1 :: Expression PredType
e1 []) l1 :: Expression PredType
l1
    = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Type -> Expression PredType
prelMap (Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf Pattern PredType
v) (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1)) [[Pattern PredType] -> Expression PredType -> Expression PredType
forall a. [Pattern a] -> Expression a -> Expression a
mkLambda [Pattern PredType
v] Expression PredType
e1, Expression PredType
l1]
  qualExpr v :: Pattern PredType
v e1 :: Expression PredType
e1                  l1 :: Expression PredType
l1
    = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Type -> Expression PredType
prelConcatMap (Pattern PredType -> Type
forall a. Typeable a => a -> Type
typeOf Pattern PredType
v) (Type -> Type
elemType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1))
      [[Pattern PredType] -> Expression PredType -> Expression PredType
forall a. [Pattern a] -> Expression a -> Expression a
mkLambda [Pattern PredType
v] Expression PredType
e1, Expression PredType
l1]
  foldFunct :: (PredType, Ident)
-> (PredType, Ident) -> Expression PredType -> Expression PredType
foldFunct v :: (PredType, Ident)
v l1 :: (PredType, Ident)
l1 e1 :: Expression PredType
e1
    = [Pattern PredType] -> Expression PredType -> Expression PredType
forall a. [Pattern a] -> Expression a -> Expression a
mkLambda (((PredType, Ident) -> Pattern PredType)
-> [(PredType, Ident)] -> [Pattern PredType]
forall a b. (a -> b) -> [a] -> [b]
map ((PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo)) [(PredType, Ident)
v, (PredType, Ident)
l1])
       (CaseType
-> Expression PredType -> [Alt PredType] -> Expression PredType
forall a. CaseType -> Expression a -> [Alt a] -> Expression a
mkCase CaseType
Rigid ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
v)
          [ SpanInfo -> Pattern PredType -> Expression PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Alt a
caseAlt SpanInfo
p Pattern PredType
t (Expression PredType -> Expression PredType -> Expression PredType
append Expression PredType
e1 ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
l1))
          , SpanInfo -> Pattern PredType -> Expression PredType -> Alt PredType
forall a. SpanInfo -> Pattern a -> Expression a -> Alt a
caseAlt SpanInfo
p ((PredType -> Ident -> Pattern PredType)
-> (PredType, Ident) -> Pattern PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SpanInfo -> PredType -> Ident -> Pattern PredType
forall a. SpanInfo -> a -> Ident -> Pattern a
VariablePattern SpanInfo
NoSpanInfo) (PredType, Ident)
v)
                                    ((PredType -> Ident -> Expression PredType)
-> (PredType, Ident) -> Expression PredType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PredType -> Ident -> Expression PredType
forall a. a -> Ident -> Expression a
mkVar (PredType, Ident)
l1)])

  append :: Expression PredType -> Expression PredType -> Expression PredType
append (ListCompr _ e1 :: Expression PredType
e1 []) l1 :: Expression PredType
l1 = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Expression PredType
prelCons (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1)) [Expression PredType
e1, Expression PredType
l1]
  append e1 :: Expression PredType
e1                  l1 :: Expression PredType
l1 =
    Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (Type -> Expression PredType
prelAppend (Type -> Type
elemType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1)) [Expression PredType
e1, Expression PredType
l1]
  prelCons :: Type -> Expression PredType
prelCons ty :: Type
ty                   =
      SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
consType Type
ty) (QualIdent -> Expression PredType)
-> QualIdent -> Expression PredType
forall a b. (a -> b) -> a -> b
$ QualIdent
qConsId

-- -----------------------------------------------------------------------------
-- Desugaring of Lists, labels, fields, and literals
-- -----------------------------------------------------------------------------

dsList :: (b -> b -> b) -> b -> [b] -> b
dsList :: (b -> b -> b) -> b -> [b] -> b
dsList = (b -> b -> b) -> b -> [b] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr

--dsLabel :: a -> [(QualIdent, a)] -> QualIdent -> a
--dsLabel def fs l = fromMaybe def (lookup l fs)

dsField :: (a -> b -> DsM (a, b)) -> a -> Field b -> DsM (a, Field b)
dsField :: (a -> b -> DsM (a, b)) -> a -> Field b -> DsM (a, Field b)
dsField ds :: a -> b -> DsM (a, b)
ds z :: a
z (Field p :: SpanInfo
p l :: QualIdent
l x :: b
x) = (b -> Field b) -> (a, b) -> (a, Field b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (SpanInfo -> QualIdent -> b -> Field b
forall a. SpanInfo -> QualIdent -> a -> Field a
Field SpanInfo
p QualIdent
l) ((a, b) -> (a, Field b)) -> DsM (a, b) -> DsM (a, Field b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> b -> DsM (a, b)
ds a
z b
x

dsLiteral :: PredType -> Literal
          -> Either (Expression PredType) (Expression PredType)
dsLiteral :: PredType
-> Literal -> Either (Expression PredType) (Expression PredType)
dsLiteral pty :: PredType
pty (Char c :: Char
c) = Expression PredType
-> Either (Expression PredType) (Expression PredType)
forall a b. b -> Either a b
Right (Expression PredType
 -> Either (Expression PredType) (Expression PredType))
-> Expression PredType
-> Either (Expression PredType) (Expression PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
pty (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Char -> Literal
Char Char
c
dsLiteral pty :: PredType
pty (Int i :: Integer
i) = Expression PredType
-> Either (Expression PredType) (Expression PredType)
forall a b. b -> Either a b
Right (Expression PredType
 -> Either (Expression PredType) (Expression PredType))
-> Expression PredType
-> Either (Expression PredType) (Expression PredType)
forall a b. (a -> b) -> a -> b
$ Type -> Expression PredType
fixLiteral (PredType -> Type
unpredType PredType
pty)
  where fixLiteral :: Type -> Expression PredType
fixLiteral (TypeConstrained tys :: [Type]
tys _) = Type -> Expression PredType
fixLiteral ([Type] -> Type
forall a. [a] -> a
head [Type]
tys)
        fixLiteral ty :: Type
ty
          | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
intType = SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
pty (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Int Integer
i
          | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
floatType = SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
pty (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Double -> Literal
Float (Double -> Literal) -> Double -> Literal
forall a b. (a -> b) -> a -> b
$ Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
i
          | Bool
otherwise = SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Type -> Expression PredType
prelFromInt (Type -> Expression PredType) -> Type -> Expression PredType
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty) (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
                          SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
predIntType (Literal -> Expression PredType) -> Literal -> Expression PredType
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Int Integer
i
dsLiteral pty :: PredType
pty f :: Literal
f@(Float _) = Expression PredType
-> Either (Expression PredType) (Expression PredType)
forall a b. b -> Either a b
Right (Expression PredType
 -> Either (Expression PredType) (Expression PredType))
-> Expression PredType
-> Either (Expression PredType) (Expression PredType)
forall a b. (a -> b) -> a -> b
$ Type -> Expression PredType
fixLiteral (PredType -> Type
unpredType PredType
pty)
  where fixLiteral :: Type -> Expression PredType
fixLiteral (TypeConstrained tys :: [Type]
tys _) = Type -> Expression PredType
fixLiteral ([Type] -> Type
forall a. [a] -> a
head [Type]
tys)
        fixLiteral ty :: Type
ty
          | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
floatType = SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
pty Literal
f
          | Bool
otherwise = SpanInfo
-> Expression PredType
-> Expression PredType
-> Expression PredType
forall a. SpanInfo -> Expression a -> Expression a -> Expression a
Apply SpanInfo
NoSpanInfo (Type -> Expression PredType
prelFromFloat (Type -> Expression PredType) -> Type -> Expression PredType
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty) (Expression PredType -> Expression PredType)
-> Expression PredType -> Expression PredType
forall a b. (a -> b) -> a -> b
$
                          SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
predFloatType Literal
f
dsLiteral pty :: PredType
pty (String cs :: String
cs) =
  Expression PredType
-> Either (Expression PredType) (Expression PredType)
forall a b. a -> Either a b
Left (Expression PredType
 -> Either (Expression PredType) (Expression PredType))
-> Expression PredType
-> Either (Expression PredType) (Expression PredType)
forall a b. (a -> b) -> a -> b
$ SpanInfo
-> PredType -> [Expression PredType] -> Expression PredType
forall a. SpanInfo -> a -> [Expression a] -> Expression a
List SpanInfo
NoSpanInfo PredType
pty ([Expression PredType] -> Expression PredType)
-> [Expression PredType] -> Expression PredType
forall a b. (a -> b) -> a -> b
$ (Char -> Expression PredType) -> String -> [Expression PredType]
forall a b. (a -> b) -> [a] -> [b]
map (SpanInfo -> PredType -> Literal -> Expression PredType
forall a. SpanInfo -> a -> Literal -> Expression a
Literal SpanInfo
NoSpanInfo PredType
pty' (Literal -> Expression PredType)
-> (Char -> Literal) -> Char -> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Literal
Char) String
cs
  where pty' :: PredType
pty' = Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ Type -> Type
elemType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty

negateLiteral :: Literal -> Literal
negateLiteral :: Literal -> Literal
negateLiteral (Int i :: Integer
i) = Integer -> Literal
Int (-Integer
i)
negateLiteral (Float f :: Double
f) = Double -> Literal
Float (-Double
f)
negateLiteral _ = String -> Literal
forall a. String -> a
internalError "Desugar.negateLiteral"

-- ---------------------------------------------------------------------------
-- Prelude entities
-- ---------------------------------------------------------------------------

preludeFun :: [Type] -> Type -> String -> Expression PredType
preludeFun :: [Type] -> Type -> String -> Expression PredType
preludeFun tys :: [Type]
tys ty :: Type
ty = SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Variable SpanInfo
NoSpanInfo (Type -> PredType
predType (Type -> PredType) -> Type -> PredType
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow Type
ty [Type]
tys)
                  (QualIdent -> Expression PredType)
-> (String -> QualIdent) -> String -> Expression PredType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QualIdent
preludeIdent

preludeIdent :: String -> QualIdent
preludeIdent :: String -> QualIdent
preludeIdent = ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
preludeMIdent (Ident -> QualIdent) -> (String -> Ident) -> String -> QualIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
mkIdent

prelBind :: Type -> Type -> Type -> Expression PredType
prelBind :: Type -> Type -> Type -> Expression PredType
prelBind ma :: Type
ma a :: Type
a mb :: Type
mb = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
ma, Type -> Type -> Type
TypeArrow Type
a Type
mb] Type
mb ">>="

prelBind_ :: Type -> Type -> Expression PredType
prelBind_ :: Type -> Type -> Expression PredType
prelBind_ ma :: Type
ma mb :: Type
mb = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
ma, Type
mb] Type
mb ">>"

prelFlip :: Type -> Type -> Type -> Expression PredType
prelFlip :: Type -> Type -> Type -> Expression PredType
prelFlip a :: Type
a b :: Type
b c :: Type
c = [Type] -> Type -> String -> Expression PredType
preludeFun [Type -> Type -> Type
TypeArrow Type
a (Type -> Type -> Type
TypeArrow Type
b Type
c), Type
b, Type
a] Type
c "flip"

prelFromInt :: Type -> Expression PredType
prelFromInt :: Type -> Expression PredType
prelFromInt a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
intType] Type
a "fromInt"

prelFromFloat :: Type -> Expression PredType
prelFromFloat :: Type -> Expression PredType
prelFromFloat a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
floatType] Type
a "fromFloat"

prelEnumFrom :: Type -> Expression PredType
prelEnumFrom :: Type -> Expression PredType
prelEnumFrom a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
a] (Type -> Type
listType Type
a) "enumFrom"

prelEnumFromTo :: Type -> Expression PredType
prelEnumFromTo :: Type -> Expression PredType
prelEnumFromTo a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
a, Type
a] (Type -> Type
listType Type
a) "enumFromTo"

prelEnumFromThen :: Type -> Expression PredType
prelEnumFromThen :: Type -> Expression PredType
prelEnumFromThen a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
a, Type
a] (Type -> Type
listType Type
a) "enumFromThen"

prelEnumFromThenTo :: Type -> Expression PredType
prelEnumFromThenTo :: Type -> Expression PredType
prelEnumFromThenTo a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
a, Type
a, Type
a] (Type -> Type
listType Type
a) "enumFromThenTo"

prelNegate :: Type -> Expression PredType
prelNegate :: Type -> Expression PredType
prelNegate a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
a] Type
a "negate"

prelFail :: Type -> Expression PredType
prelFail :: Type -> Expression PredType
prelFail ma :: Type
ma = [Type] -> Type -> String -> Expression PredType
preludeFun [Type
stringType] Type
ma "fail"

prelFailed :: Type -> Expression PredType
prelFailed :: Type -> Expression PredType
prelFailed a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [] Type
a "failed"

prelUnknown :: Type -> Expression PredType
prelUnknown :: Type -> Expression PredType
prelUnknown a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [] Type
a "unknown"

prelMap :: Type -> Type -> Expression PredType
prelMap :: Type -> Type -> Expression PredType
prelMap a :: Type
a b :: Type
b = [Type] -> Type -> String -> Expression PredType
preludeFun [Type -> Type -> Type
TypeArrow Type
a Type
b, Type -> Type
listType Type
a] (Type -> Type
listType Type
b) "map"

prelFoldr :: Type -> Type -> Expression PredType
prelFoldr :: Type -> Type -> Expression PredType
prelFoldr a :: Type
a b :: Type
b =
  [Type] -> Type -> String -> Expression PredType
preludeFun [Type -> Type -> Type
TypeArrow Type
a (Type -> Type -> Type
TypeArrow Type
b Type
b), Type
b, Type -> Type
listType Type
a] Type
b "foldr"

prelAppend :: Type -> Expression PredType
prelAppend :: Type -> Expression PredType
prelAppend a :: Type
a = [Type] -> Type -> String -> Expression PredType
preludeFun [Type -> Type
listType Type
a, Type -> Type
listType Type
a] (Type -> Type
listType Type
a) "++"

prelConcatMap :: Type -> Type -> Expression PredType
prelConcatMap :: Type -> Type -> Expression PredType
prelConcatMap a :: Type
a b :: Type
b =
  [Type] -> Type -> String -> Expression PredType
preludeFun [Type -> Type -> Type
TypeArrow Type
a (Type -> Type
listType Type
b), Type -> Type
listType Type
a] (Type -> Type
listType Type
b) "concatMap"

(=:<=) :: Expression PredType -> Expression PredType -> Expression PredType
e1 :: Expression PredType
e1 =:<= :: Expression PredType -> Expression PredType -> Expression PredType
=:<= e2 :: Expression PredType
e2 = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply ([Type] -> Type -> String -> Expression PredType
preludeFun [Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1, Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e2] Type
boolType "=:<=") [Expression PredType
e1, Expression PredType
e2]

(=:=) :: Expression PredType -> Expression PredType -> Expression PredType
e1 :: Expression PredType
e1 =:= :: Expression PredType -> Expression PredType -> Expression PredType
=:= e2 :: Expression PredType
e2 = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply ([Type] -> Type -> String -> Expression PredType
preludeFun [Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e1, Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e2] Type
boolType "=:=") [Expression PredType
e1, Expression PredType
e2]

(&>) :: Expression PredType -> Expression PredType -> Expression PredType
e1 :: Expression PredType
e1 &> :: Expression PredType -> Expression PredType -> Expression PredType
&> e2 :: Expression PredType
e2 = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply ([Type] -> Type -> String -> Expression PredType
preludeFun [Type
boolType, Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e2] (Expression PredType -> Type
forall a. Typeable a => a -> Type
typeOf Expression PredType
e2) "cond") [Expression PredType
e1, Expression PredType
e2]

(&) :: Expression PredType -> Expression PredType -> Expression PredType
e1 :: Expression PredType
e1 & :: Expression PredType -> Expression PredType -> Expression PredType
& e2 :: Expression PredType
e2 = Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply ([Type] -> Type -> String -> Expression PredType
preludeFun [Type
boolType, Type
boolType] Type
boolType "&") [Expression PredType
e1, Expression PredType
e2]

truePat :: Pattern PredType
truePat :: Pattern PredType
truePat = SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
predBoolType QualIdent
qTrueId []

falsePat :: Pattern PredType
falsePat :: Pattern PredType
falsePat = SpanInfo
-> PredType -> QualIdent -> [Pattern PredType] -> Pattern PredType
forall a. SpanInfo -> a -> QualIdent -> [Pattern a] -> Pattern a
ConstructorPattern SpanInfo
NoSpanInfo PredType
predBoolType QualIdent
qFalseId []

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

conType :: QualIdent -> ValueEnv -> ([Ident], TypeScheme)
conType :: QualIdent -> ValueEnv -> ([Ident], TypeScheme)
conType c :: QualIdent
c vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
c ValueEnv
vEnv of
  [DataConstructor _ _ ls :: [Ident]
ls ty :: TypeScheme
ty] -> ([Ident]
ls , TypeScheme
ty)
  [NewtypeConstructor _ l :: Ident
l ty :: TypeScheme
ty] -> ([Ident
l], TypeScheme
ty)
  _                           -> String -> ([Ident], TypeScheme)
forall a. String -> a
internalError (String -> ([Ident], TypeScheme))
-> String -> ([Ident], TypeScheme)
forall a b. (a -> b) -> a -> b
$ "Desguar.conType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
c

varType :: QualIdent -> ValueEnv -> TypeScheme
varType :: QualIdent -> ValueEnv -> TypeScheme
varType v :: QualIdent
v vEnv :: ValueEnv
vEnv = case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
v ValueEnv
vEnv of
  Value _ _ _ tySc :: TypeScheme
tySc : _ -> TypeScheme
tySc
  Label _ _   tySc :: TypeScheme
tySc : _ -> TypeScheme
tySc
  _                    -> String -> TypeScheme
forall a. String -> a
internalError (String -> TypeScheme) -> String -> TypeScheme
forall a b. (a -> b) -> a -> b
$ "Desugar.varType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
v

elemType :: Type -> Type
elemType :: Type -> Type
elemType (TypeApply (TypeConstructor tc :: QualIdent
tc) ty :: Type
ty) | QualIdent
tc QualIdent -> QualIdent -> Bool
forall a. Eq a => a -> a -> Bool
== QualIdent
qListId = Type
ty
elemType ty :: Type
ty = String -> Type
forall a. String -> a
internalError (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ "Base.Types.elemType " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty

applyConstr :: PredType -> QualIdent -> [Type] -> [Expression PredType]
            -> Expression PredType
applyConstr :: PredType
-> QualIdent
-> [Type]
-> [Expression PredType]
-> Expression PredType
applyConstr pty :: PredType
pty c :: QualIdent
c tys :: [Type]
tys =
  Expression PredType -> [Expression PredType] -> Expression PredType
forall a. Expression a -> [Expression a] -> Expression a
apply (SpanInfo -> PredType -> QualIdent -> Expression PredType
forall a. SpanInfo -> a -> QualIdent -> Expression a
Constructor SpanInfo
NoSpanInfo
    (Type -> PredType
predType ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
TypeArrow (PredType -> Type
unpredType PredType
pty) [Type]
tys)) QualIdent
c)

-- The function 'instType' instantiates the universally quantified
-- type variables of a type scheme with fresh type variables. Since this
-- function is used only to instantiate the closed types of record
-- constructors (recall that no existentially quantified type
-- variables are allowed for records), the compiler can reuse the same
-- monomorphic type variables for every instantiated type.

instType :: TypeScheme -> Type
instType :: TypeScheme -> Type
instType (ForAll _ pty :: PredType
pty) = Type -> Type
inst (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ PredType -> Type
unpredType PredType
pty
  where inst :: Type -> Type
inst (TypeConstructor     tc :: QualIdent
tc) = QualIdent -> Type
TypeConstructor QualIdent
tc
        inst (TypeApply      ty1 :: Type
ty1 ty2 :: Type
ty2) = Type -> Type -> Type
TypeApply (Type -> Type
inst Type
ty1) (Type -> Type
inst Type
ty2)
        inst (TypeVariable        tv :: Int
tv) = Int -> Type
TypeVariable (-1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tv)
        inst (TypeArrow      ty1 :: Type
ty1 ty2 :: Type
ty2) = Type -> Type -> Type
TypeArrow (Type -> Type
inst Type
ty1) (Type -> Type
inst Type
ty2)
        inst ty :: Type
ty                       = Type
ty

-- Retrieve all constructors of a type
constructors :: QualIdent -> DsM [DataConstr]
constructors :: QualIdent -> DsM [DataConstr]
constructors tc :: QualIdent
tc = DsM TCEnv
getTyConsEnv DsM TCEnv -> (TCEnv -> DsM [DataConstr]) -> DsM [DataConstr]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \tcEnv :: TCEnv
tcEnv -> [DataConstr] -> DsM [DataConstr]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DataConstr] -> DsM [DataConstr])
-> [DataConstr] -> DsM [DataConstr]
forall a b. (a -> b) -> a -> b
$
  case QualIdent -> TCEnv -> [TypeInfo]
qualLookupTypeInfo QualIdent
tc TCEnv
tcEnv of
    [DataType     _ _ cs :: [DataConstr]
cs] -> [DataConstr]
cs
    [RenamingType _ _ nc :: DataConstr
nc] -> [DataConstr
nc]
    _                     ->
      String -> [DataConstr]
forall a. String -> a
internalError (String -> [DataConstr]) -> String -> [DataConstr]
forall a b. (a -> b) -> a -> b
$ "Transformations.Desugar.constructors: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
forall a. Show a => a -> String
show QualIdent
tc

-- The function 'argumentTypes' returns the labels and the argument types
-- of a data constructor instantiated at a particular type.

argumentTypes :: Type -> QualIdent -> ValueEnv -> ([QualIdent], [Type])
argumentTypes :: Type -> QualIdent -> ValueEnv -> ([QualIdent], [Type])
argumentTypes ty :: Type
ty c :: QualIdent
c vEnv :: ValueEnv
vEnv =
  ((Ident -> QualIdent) -> [Ident] -> [QualIdent]
forall a b. (a -> b) -> [a] -> [b]
map (QualIdent -> Ident -> QualIdent
qualifyLike QualIdent
c) [Ident]
ls, (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (TypeSubst -> Type -> Type
forall a. SubstType a => TypeSubst -> a -> a
subst (Type -> Type -> TypeSubst -> TypeSubst
matchType Type
ty0 Type
ty TypeSubst
forall a b. Subst a b
idSubst)) [Type]
tys)
  where (ls :: [Ident]
ls, ForAll _ (PredType _ ty' :: Type
ty')) = QualIdent -> ValueEnv -> ([Ident], TypeScheme)
conType QualIdent
c ValueEnv
vEnv
        (tys :: [Type]
tys, ty0 :: Type
ty0) = Type -> ([Type], Type)
arrowUnapply Type
ty'