{-# 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)
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)
data DesugarState = DesugarState
{ DesugarState -> ModuleIdent
moduleIdent :: ModuleIdent
, DesugarState -> [KnownExtension]
extensions :: [KnownExtension]
, DesugarState -> TCEnv
tyConsEnv :: TCEnv
, DesugarState -> ValueEnv
valueEnv :: ValueEnv
, DesugarState -> Integer
nextId :: Integer
}
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
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)
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''''
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
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
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]
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
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 []
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
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
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]
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"
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 :: [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
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
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')
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)
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
(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
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)
([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
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
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')
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
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
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
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
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
[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
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
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
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"
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 []
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)
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
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
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'