module Language.PureScript.Sugar.CaseDeclarations
( desugarCases
, desugarCasesModule
, desugarCaseGuards
) where
import Prelude
import Protolude (ordNub)
import Data.List (groupBy, foldl1')
import Data.Maybe (catMaybes, mapMaybe)
import Control.Monad ((<=<), forM, replicateM, join, unless)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Supply.Class
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Names
import Language.PureScript.TypeChecker.Monad (guardWith)
desugarCasesModule
:: (MonadSupply m, MonadError MultipleErrors m)
=> Module
-> m Module
desugarCasesModule :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
Module -> m Module
desugarCasesModule (Module SourceSpan
ss [Comment]
coms ModuleName
name [Declaration]
ds Maybe [DeclarationRef]
exps) =
forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
rethrow (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
name)) forall a b. (a -> b) -> a -> b
$
SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
desugarCases forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
desugarAbs forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
validateCases forall a b. (a -> b) -> a -> b
$ [Declaration]
ds)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DeclarationRef]
exps
desugarCaseGuards
:: forall m. (MonadSupply m, MonadError MultipleErrors m)
=> [Declaration]
-> m [Declaration]
desugarCaseGuards :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
desugarCaseGuards [Declaration]
declarations = forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU [Declaration]
declarations forall {m :: * -> *}. MonadSupply m => Declaration -> m Declaration
go
where
go :: Declaration -> m Declaration
go Declaration
d =
let (Declaration -> m Declaration
f, Expr -> m Expr
_, Binder -> m Binder
_) = forall (m :: * -> *).
Monad m =>
(Declaration -> m Declaration)
-> (Expr -> m Expr)
-> (Binder -> m Binder)
-> (Declaration -> m Declaration, Expr -> m Expr,
Binder -> m Binder)
everywhereOnValuesM forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *). MonadSupply m => SourceSpan -> Expr -> m Expr
desugarGuardedExprs (Declaration -> SourceSpan
declSourceSpan Declaration
d)) forall (m :: * -> *) a. Monad m => a -> m a
return
in Declaration -> m Declaration
f Declaration
d
desugarGuardedExprs
:: forall m. (MonadSupply m)
=> SourceSpan
-> Expr
-> m Expr
desugarGuardedExprs :: forall (m :: * -> *). MonadSupply m => SourceSpan -> Expr -> m Expr
desugarGuardedExprs SourceSpan
ss (Case [Expr]
scrut [CaseAlternative]
alternatives)
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr -> Bool
isTrivialExpr [Expr]
scrut = do
([Expr]
scrut', [Declaration]
scrut_decls) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Expr]
scrut (\Expr
e -> do
Ident
scrut_id <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
scrut_id)
, SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl (SourceSpan
ss, []) Ident
scrut_id NameKind
Private [] [Expr -> GuardedExpr
MkUnguarded Expr
e]
)
)
WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
FromLet [Declaration]
scrut_decls forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSupply m => SourceSpan -> Expr -> m Expr
desugarGuardedExprs SourceSpan
ss ([Expr] -> [CaseAlternative] -> Expr
Case [Expr]
scrut' [CaseAlternative]
alternatives)
where
isTrivialExpr :: Expr -> Bool
isTrivialExpr (Var SourceSpan
_ Qualified Ident
_) = Bool
True
isTrivialExpr (Literal SourceSpan
_ Literal Expr
_) = Bool
True
isTrivialExpr (Accessor PSString
_ Expr
e) = Expr -> Bool
isTrivialExpr Expr
e
isTrivialExpr (Parens Expr
e) = Expr -> Bool
isTrivialExpr Expr
e
isTrivialExpr (PositionedValue SourceSpan
_ [Comment]
_ Expr
e) = Expr -> Bool
isTrivialExpr Expr
e
isTrivialExpr (TypedValue Bool
_ Expr
e SourceType
_) = Expr -> Bool
isTrivialExpr Expr
e
isTrivialExpr Expr
_ = Bool
False
desugarGuardedExprs SourceSpan
ss (Case [Expr]
scrut [CaseAlternative]
alternatives) =
let
desugarAlternatives :: [CaseAlternative]
-> m [CaseAlternative]
desugarAlternatives :: [CaseAlternative] -> m [CaseAlternative]
desugarAlternatives [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
desugarAlternatives (a :: CaseAlternative
a@(CaseAlternative [Binder]
_ [MkUnguarded Expr
_]) : [CaseAlternative]
as) =
(CaseAlternative
a forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CaseAlternative] -> m [CaseAlternative]
desugarAlternatives [CaseAlternative]
as
desugarAlternatives (CaseAlternative [Binder]
ab [GuardedExpr]
ge : [CaseAlternative]
as)
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GuardedExpr]
cond_guards) =
([Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder]
ab [GuardedExpr]
cond_guards forall a. a -> [a] -> [a]
:)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binder]
-> [GuardedExpr] -> [CaseAlternative] -> m [CaseAlternative]
desugarGuardedAlternative [Binder]
ab [GuardedExpr]
rest [CaseAlternative]
as
| Bool
otherwise = [Binder]
-> [GuardedExpr] -> [CaseAlternative] -> m [CaseAlternative]
desugarGuardedAlternative [Binder]
ab [GuardedExpr]
ge [CaseAlternative]
as
where
([GuardedExpr]
cond_guards, [GuardedExpr]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span GuardedExpr -> Bool
isSingleCondGuard [GuardedExpr]
ge
isSingleCondGuard :: GuardedExpr -> Bool
isSingleCondGuard (GuardedExpr [ConditionGuard Expr
_] Expr
_) = Bool
True
isSingleCondGuard GuardedExpr
_ = Bool
False
desugarGuardedAlternative :: [Binder]
-> [GuardedExpr]
-> [CaseAlternative]
-> m [CaseAlternative]
desugarGuardedAlternative :: [Binder]
-> [GuardedExpr] -> [CaseAlternative] -> m [CaseAlternative]
desugarGuardedAlternative [Binder]
_vb [] [CaseAlternative]
rem_alts =
[CaseAlternative] -> m [CaseAlternative]
desugarAlternatives [CaseAlternative]
rem_alts
desugarGuardedAlternative [Binder]
vb (GuardedExpr [Guard]
gs Expr
e : [GuardedExpr]
ge) [CaseAlternative]
rem_alts = do
Expr
rhs <- [Binder]
-> [GuardedExpr]
-> [CaseAlternative]
-> ((Int -> [CaseAlternative]) -> Expr)
-> m Expr
desugarAltOutOfLine [Binder]
vb [GuardedExpr]
ge [CaseAlternative]
rem_alts forall a b. (a -> b) -> a -> b
$ \Int -> [CaseAlternative]
alt_fail ->
let
alt_fail' :: Int -> [CaseAlternative]
alt_fail' Int
n | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Binder -> Bool
isIrrefutable [Binder]
vb = []
| Bool
otherwise = Int -> [CaseAlternative]
alt_fail Int
n
in [Expr] -> [CaseAlternative] -> Expr
Case [Expr]
scrut
([Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder]
vb [Expr -> GuardedExpr
MkUnguarded ([Guard] -> Expr -> (Int -> [CaseAlternative]) -> Expr
desugarGuard [Guard]
gs Expr
e Int -> [CaseAlternative]
alt_fail)]
forall a. a -> [a] -> [a]
: Int -> [CaseAlternative]
alt_fail' (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
scrut))
forall (m :: * -> *) a. Monad m => a -> m a
return [ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder]
scrut_nullbinder [Expr -> GuardedExpr
MkUnguarded Expr
rhs]]
desugarGuard :: [Guard] -> Expr -> (Int ->[CaseAlternative]) -> Expr
desugarGuard :: [Guard] -> Expr -> (Int -> [CaseAlternative]) -> Expr
desugarGuard [] Expr
e Int -> [CaseAlternative]
_ = Expr
e
desugarGuard (ConditionGuard Expr
c : [Guard]
gs) Expr
e Int -> [CaseAlternative]
match_failed
| Expr -> Bool
isTrueExpr Expr
c = [Guard] -> Expr -> (Int -> [CaseAlternative]) -> Expr
desugarGuard [Guard]
gs Expr
e Int -> [CaseAlternative]
match_failed
| Bool
otherwise =
[Expr] -> [CaseAlternative] -> Expr
Case [Expr
c]
([Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [SourceSpan -> Literal Binder -> Binder
LiteralBinder SourceSpan
ss (forall a. Bool -> Literal a
BooleanLiteral Bool
True)]
[Expr -> GuardedExpr
MkUnguarded ([Guard] -> Expr -> (Int -> [CaseAlternative]) -> Expr
desugarGuard [Guard]
gs Expr
e Int -> [CaseAlternative]
match_failed)] forall a. a -> [a] -> [a]
: Int -> [CaseAlternative]
match_failed Int
1)
desugarGuard (PatternGuard Binder
vb Expr
g : [Guard]
gs) Expr
e Int -> [CaseAlternative]
match_failed =
[Expr] -> [CaseAlternative] -> Expr
Case [Expr
g]
([Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
vb] [Expr -> GuardedExpr
MkUnguarded ([Guard] -> Expr -> (Int -> [CaseAlternative]) -> Expr
desugarGuard [Guard]
gs Expr
e Int -> [CaseAlternative]
match_failed)]
forall a. a -> [a] -> [a]
: [CaseAlternative]
match_failed')
where
match_failed' :: [CaseAlternative]
match_failed' | Binder -> Bool
isIrrefutable Binder
vb = []
| Bool
otherwise = Int -> [CaseAlternative]
match_failed Int
1
desugarAltOutOfLine :: [Binder]
-> [GuardedExpr]
-> [CaseAlternative]
-> ((Int -> [CaseAlternative]) -> Expr)
-> m Expr
desugarAltOutOfLine :: [Binder]
-> [GuardedExpr]
-> [CaseAlternative]
-> ((Int -> [CaseAlternative]) -> Expr)
-> m Expr
desugarAltOutOfLine [Binder]
alt_binder [GuardedExpr]
rem_guarded [CaseAlternative]
rem_alts (Int -> [CaseAlternative]) -> Expr
mk_body
| Just Expr
rem_case <- Maybe Expr
mkCaseOfRemainingGuardsAndAlts = do
Expr
desugared <- forall (m :: * -> *). MonadSupply m => SourceSpan -> Expr -> m Expr
desugarGuardedExprs SourceSpan
ss Expr
rem_case
Ident
rem_case_id <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
Ident
unused_binder <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
let
goto_rem_case :: Expr
goto_rem_case :: Expr
goto_rem_case = SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
rem_case_id)
Expr -> Expr -> Expr
`App` SourceSpan -> Literal Expr -> Expr
Literal SourceSpan
ss (forall a. Bool -> Literal a
BooleanLiteral Bool
True)
alt_fail :: Int -> [CaseAlternative]
alt_fail :: Int -> [CaseAlternative]
alt_fail Int
n = [[Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative (forall a. Int -> a -> [a]
replicate Int
n Binder
NullBinder) [Expr -> GuardedExpr
MkUnguarded Expr
goto_rem_case]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
FromLet [
SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl (SourceSpan
ss, []) Ident
rem_case_id NameKind
Private []
[Expr -> GuardedExpr
MkUnguarded (Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
unused_binder) Expr
desugared)]
] ((Int -> [CaseAlternative]) -> Expr
mk_body Int -> [CaseAlternative]
alt_fail)
| Bool
otherwise
= forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Int -> [CaseAlternative]) -> Expr
mk_body (forall a b. a -> b -> a
const [])
where
mkCaseOfRemainingGuardsAndAlts :: Maybe Expr
mkCaseOfRemainingGuardsAndAlts
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GuardedExpr]
rem_guarded)
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Expr] -> [CaseAlternative] -> Expr
Case [Expr]
scrut ([Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder]
alt_binder [GuardedExpr]
rem_guarded forall a. a -> [a] -> [a]
: [CaseAlternative]
rem_alts)
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CaseAlternative]
rem_alts)
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Expr] -> [CaseAlternative] -> Expr
Case [Expr]
scrut [CaseAlternative]
rem_alts
| Bool
otherwise
= forall a. Maybe a
Nothing
scrut_nullbinder :: [Binder]
scrut_nullbinder :: [Binder]
scrut_nullbinder = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
scrut) Binder
NullBinder
optimize :: Expr -> Expr
optimize :: Expr -> Expr
optimize (Case [Expr]
_ [CaseAlternative [Binder]
vb [MkUnguarded Expr
v]])
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Binder -> Bool
isNullBinder [Binder]
vb = Expr
v
where
isNullBinder :: Binder -> Bool
isNullBinder Binder
NullBinder = Bool
True
isNullBinder (PositionedBinder SourceSpan
_ [Comment]
_ Binder
b) = Binder -> Bool
isNullBinder Binder
b
isNullBinder (TypedBinder SourceType
_ Binder
b) = Binder -> Bool
isNullBinder Binder
b
isNullBinder Binder
_ = Bool
False
optimize Expr
e = Expr
e
in do
[CaseAlternative]
alts' <- [CaseAlternative] -> m [CaseAlternative]
desugarAlternatives [CaseAlternative]
alternatives
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Expr -> Expr
optimize ([Expr] -> [CaseAlternative] -> Expr
Case [Expr]
scrut [CaseAlternative]
alts')
desugarGuardedExprs SourceSpan
ss (TypedValue Bool
inferred Expr
e SourceType
ty) =
Bool -> Expr -> SourceType -> Expr
TypedValue Bool
inferred forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSupply m => SourceSpan -> Expr -> m Expr
desugarGuardedExprs SourceSpan
ss Expr
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SourceType
ty
desugarGuardedExprs SourceSpan
_ (PositionedValue SourceSpan
ss [Comment]
comms Expr
e) =
SourceSpan -> [Comment] -> Expr -> Expr
PositionedValue SourceSpan
ss [Comment]
comms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSupply m => SourceSpan -> Expr -> m Expr
desugarGuardedExprs SourceSpan
ss Expr
e
desugarGuardedExprs SourceSpan
_ Expr
v = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
v
validateCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
validateCases :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
validateCases = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU Declaration -> m Declaration
f
where
(Declaration -> m Declaration
f, Expr -> m Expr
_, Binder -> m Binder
_) = forall (m :: * -> *).
Monad m =>
(Declaration -> m Declaration)
-> (Expr -> m Expr)
-> (Binder -> m Binder)
-> (Declaration -> m Declaration, Expr -> m Expr,
Binder -> m Binder)
everywhereOnValuesM forall (m :: * -> *) a. Monad m => a -> m a
return Expr -> m Expr
validate forall (m :: * -> *) a. Monad m => a -> m a
return
validate :: Expr -> m Expr
validate :: Expr -> m Expr
validate c :: Expr
c@(Case [Expr]
vs [CaseAlternative]
alts) = do
let l :: Int
l = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
vs
alts' :: [CaseAlternative]
alts' = forall a. (a -> Bool) -> [a] -> [a]
filter ((Int
l forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. CaseAlternative -> [Binder]
caseAlternativeBinders) [CaseAlternative]
alts
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CaseAlternative]
alts') forall a b. (a -> b) -> a -> b
$
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrorMessage] -> MultipleErrors
MultipleErrors forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [Binder] -> ErrorMessage
altError Int
l) (CaseAlternative -> [Binder]
caseAlternativeBinders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CaseAlternative]
alts')
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
c
validate Expr
other = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
other
altError :: Int -> [Binder] -> ErrorMessage
altError :: Int -> [Binder] -> ErrorMessage
altError Int
l [Binder]
bs = SourceSpan -> ErrorMessage -> ErrorMessage
withPosition SourceSpan
pos forall a b. (a -> b) -> a -> b
$ [ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage [] forall a b. (a -> b) -> a -> b
$ Int -> [Binder] -> SimpleErrorMessage
CaseBinderLengthDiffers Int
l [Binder]
bs
where
pos :: SourceSpan
pos = forall a. (a -> a -> a) -> [a] -> a
foldl1' SourceSpan -> SourceSpan -> SourceSpan
widenSpan (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Binder -> Maybe SourceSpan
positionedBinder [Binder]
bs)
widenSpan :: SourceSpan -> SourceSpan -> SourceSpan
widenSpan (SourceSpan String
n SourcePos
start SourcePos
end) (SourceSpan String
_ SourcePos
start' SourcePos
end') =
String -> SourcePos -> SourcePos -> SourceSpan
SourceSpan String
n (forall a. Ord a => a -> a -> a
min SourcePos
start SourcePos
start') (forall a. Ord a => a -> a -> a
max SourcePos
end SourcePos
end')
positionedBinder :: Binder -> Maybe SourceSpan
positionedBinder (PositionedBinder SourceSpan
p [Comment]
_ Binder
_) = forall a. a -> Maybe a
Just SourceSpan
p
positionedBinder Binder
_ = forall a. Maybe a
Nothing
desugarAbs :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarAbs :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
desugarAbs = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU Declaration -> m Declaration
f
where
(Declaration -> m Declaration
f, Expr -> m Expr
_, Binder -> m Binder
_) = forall (m :: * -> *).
Monad m =>
(Declaration -> m Declaration)
-> (Expr -> m Expr)
-> (Binder -> m Binder)
-> (Declaration -> m Declaration, Expr -> m Expr,
Binder -> m Binder)
everywhereOnValuesM forall (m :: * -> *) a. Monad m => a -> m a
return Expr -> m Expr
replace forall (m :: * -> *) a. Monad m => a -> m a
return
replace :: Expr -> m Expr
replace :: Expr -> m Expr
replace (Abs (Binder -> Binder
stripPositioned -> (VarBinder SourceSpan
ss Ident
i)) Expr
val) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss Ident
i) Expr
val)
replace (Abs Binder
binder Expr
val) = do
Ident
ident <- forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Binder -> Expr -> Expr
Abs (SourceSpan -> Ident -> Binder
VarBinder SourceSpan
nullSourceSpan Ident
ident) forall a b. (a -> b) -> a -> b
$ [Expr] -> [CaseAlternative] -> Expr
Case [SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
nullSourceSpan (forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos Ident
ident)] [[Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
binder] [Expr -> GuardedExpr
MkUnguarded Expr
val]]
replace Expr
other = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
other
stripPositioned :: Binder -> Binder
stripPositioned :: Binder -> Binder
stripPositioned (PositionedBinder SourceSpan
_ [Comment]
_ Binder
binder) = Binder -> Binder
stripPositioned Binder
binder
stripPositioned Binder
binder = Binder
binder
desugarCases :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarCases :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
desugarCases = [Declaration] -> m [Declaration]
desugarRest forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b.
MonadError MultipleErrors m =>
[a] -> (a -> m b) -> m [b]
parU forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
toDecls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy Declaration -> Declaration -> Bool
inSameGroup
where
desugarRest :: [Declaration] -> m [Declaration]
desugarRest :: [Declaration] -> m [Declaration]
desugarRest (TypeInstanceDeclaration SourceAnn
sa SourceAnn
na ChainId
cd Integer
idx Either Text Ident
name [SourceConstraint]
constraints Qualified (ProperName 'ClassName)
className [SourceType]
tys TypeInstanceBody
ds : [Declaration]
rest) =
(:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SourceAnn
-> SourceAnn
-> ChainId
-> Integer
-> Either Text Ident
-> [SourceConstraint]
-> Qualified (ProperName 'ClassName)
-> [SourceType]
-> TypeInstanceBody
-> Declaration
TypeInstanceDeclaration SourceAnn
sa SourceAnn
na ChainId
cd Integer
idx Either Text Ident
name [SourceConstraint]
constraints Qualified (ProperName 'ClassName)
className [SourceType]
tys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *).
Applicative f =>
([Declaration] -> f [Declaration])
-> TypeInstanceBody -> f TypeInstanceBody
traverseTypeInstanceBody forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
desugarCases TypeInstanceBody
ds) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> m [Declaration]
desugarRest [Declaration]
rest
desugarRest (ValueDecl SourceAnn
sa Ident
name NameKind
nameKind [Binder]
bs [GuardedExpr]
result : [Declaration]
rest) =
let (Declaration -> m Declaration
_, Expr -> m Expr
f, Binder -> m Binder
_) = forall (m :: * -> *).
Monad m =>
(Declaration -> m Declaration)
-> (Expr -> m Expr)
-> (Binder -> m Binder)
-> (Declaration -> m Declaration, Expr -> m Expr,
Binder -> m Binder)
everywhereOnValuesTopDownM forall (m :: * -> *) a. Monad m => a -> m a
return forall {f :: * -> *}.
(MonadSupply f, MonadError MultipleErrors f) =>
Expr -> f Expr
go forall (m :: * -> *) a. Monad m => a -> m a
return
f' :: [GuardedExpr] -> m [GuardedExpr]
f' = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(GuardedExpr [Guard]
gs Expr
e) -> [Guard] -> Expr -> GuardedExpr
GuardedExpr [Guard]
gs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> m Expr
f Expr
e)
in (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
name NameKind
nameKind [Binder]
bs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GuardedExpr] -> m [GuardedExpr]
f' [GuardedExpr]
result) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Declaration] -> m [Declaration]
desugarRest [Declaration]
rest
where
go :: Expr -> f Expr
go (Let WhereProvenance
w [Declaration]
ds Expr
val') = WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
w forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
desugarCases [Declaration]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr
val'
go Expr
other = forall (m :: * -> *) a. Monad m => a -> m a
return Expr
other
desugarRest (Declaration
d : [Declaration]
ds) = (:) Declaration
d forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration] -> m [Declaration]
desugarRest [Declaration]
ds
desugarRest [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
inSameGroup :: Declaration -> Declaration -> Bool
inSameGroup :: Declaration -> Declaration -> Bool
inSameGroup (ValueDeclaration ValueDeclarationData [GuardedExpr]
vd1) (ValueDeclaration ValueDeclarationData [GuardedExpr]
vd2) = forall a. ValueDeclarationData a -> Ident
valdeclIdent ValueDeclarationData [GuardedExpr]
vd1 forall a. Eq a => a -> a -> Bool
== forall a. ValueDeclarationData a -> Ident
valdeclIdent ValueDeclarationData [GuardedExpr]
vd2
inSameGroup Declaration
_ Declaration
_ = Bool
False
toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
toDecls :: forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
toDecls [ValueDecl sa :: SourceAnn
sa@(SourceSpan
ss, [Comment]
_) Ident
ident NameKind
nameKind [Binder]
bs [MkUnguarded Expr
val]] | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Binder -> Bool
isIrrefutable [Binder]
bs = do
[Ident]
args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Binder -> m Ident
fromVarBinder [Binder]
bs
let body :: Expr
body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Binder -> Expr -> Expr
Abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> Ident -> Binder
VarBinder SourceSpan
ss) Expr
val [Ident]
args
forall e (m :: * -> *). MonadError e m => e -> Bool -> m ()
guardWith (SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss (Maybe Ident -> SimpleErrorMessage
OverlappingArgNames (forall a. a -> Maybe a
Just Ident
ident))) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Ord a => [a] -> [a]
ordNub [Ident]
args) forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ident]
args
forall (m :: * -> *) a. Monad m => a -> m a
return [SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl SourceAnn
sa Ident
ident NameKind
nameKind [] [Expr -> GuardedExpr
MkUnguarded Expr
body]]
where
fromVarBinder :: Binder -> m Ident
fromVarBinder :: Binder -> m Ident
fromVarBinder Binder
NullBinder = forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
fromVarBinder (VarBinder SourceSpan
_ Ident
name) = forall (m :: * -> *) a. Monad m => a -> m a
return Ident
name
fromVarBinder (PositionedBinder SourceSpan
_ [Comment]
_ Binder
b) = Binder -> m Ident
fromVarBinder Binder
b
fromVarBinder (TypedBinder SourceType
_ Binder
b) = Binder -> m Ident
fromVarBinder Binder
b
fromVarBinder Binder
_ = forall a. HasCallStack => String -> a
internalError String
"fromVarBinder: Invalid argument"
toDecls ds :: [Declaration]
ds@(ValueDecl (SourceSpan
ss, [Comment]
_) Ident
ident NameKind
_ [Binder]
bs (GuardedExpr
result : [GuardedExpr]
_) : [Declaration]
_) = do
let tuples :: [([Binder], [GuardedExpr])]
tuples = forall a b. (a -> b) -> [a] -> [b]
map Declaration -> ([Binder], [GuardedExpr])
toTuple [Declaration]
ds
isGuarded :: GuardedExpr -> Bool
isGuarded (MkUnguarded Expr
_) = Bool
False
isGuarded GuardedExpr
_ = Bool
True
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Binder]
bs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([Binder], [GuardedExpr])]
tuples) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
ArgListLengthsDiffer Ident
ident
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Binder]
bs) Bool -> Bool -> Bool
|| GuardedExpr -> Bool
isGuarded GuardedExpr
result) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
ss forall a b. (a -> b) -> a -> b
$ Ident -> SimpleErrorMessage
DuplicateValueDeclaration Ident
ident
Declaration
caseDecl <- forall (m :: * -> *).
MonadSupply m =>
SourceSpan -> Ident -> [([Binder], [GuardedExpr])] -> m Declaration
makeCaseDeclaration SourceSpan
ss Ident
ident [([Binder], [GuardedExpr])]
tuples
forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration
caseDecl]
toDecls [Declaration]
ds = forall (m :: * -> *) a. Monad m => a -> m a
return [Declaration]
ds
toTuple :: Declaration -> ([Binder], [GuardedExpr])
toTuple :: Declaration -> ([Binder], [GuardedExpr])
toTuple (ValueDecl SourceAnn
_ Ident
_ NameKind
_ [Binder]
bs [GuardedExpr]
result) = ([Binder]
bs, [GuardedExpr]
result)
toTuple Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"Not a value declaration"
makeCaseDeclaration :: forall m. (MonadSupply m) => SourceSpan -> Ident -> [([Binder], [GuardedExpr])] -> m Declaration
makeCaseDeclaration :: forall (m :: * -> *).
MonadSupply m =>
SourceSpan -> Ident -> [([Binder], [GuardedExpr])] -> m Declaration
makeCaseDeclaration SourceSpan
ss Ident
ident [([Binder], [GuardedExpr])]
alternatives = do
let namedArgs :: [[Maybe (SourceSpan, Ident)]]
namedArgs = forall a b. (a -> b) -> [a] -> [b]
map Binder -> Maybe (SourceSpan, Ident)
findName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([Binder], [GuardedExpr])]
alternatives
argNames :: [Maybe (SourceSpan, Ident)]
argNames = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 [Maybe (SourceSpan, Ident)]
-> [Maybe (SourceSpan, Ident)] -> [Maybe (SourceSpan, Ident)]
resolveNames [[Maybe (SourceSpan, Ident)]]
namedArgs
[(SourceSpan, Ident)]
args <- if forall a. Ord a => [a] -> Bool
allUnique (forall a. [Maybe a] -> [a]
catMaybes [Maybe (SourceSpan, Ident)]
argNames)
then forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Maybe (SourceSpan, Ident) -> m (SourceSpan, Ident)
argName [Maybe (SourceSpan, Ident)]
argNames
else forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe (SourceSpan, Ident)]
argNames) ((SourceSpan
nullSourceSpan, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSupply m => m Ident
freshIdent')
let vars :: [Expr]
vars = forall a b. (a -> b) -> [a] -> [b]
map (SourceSpan -> Qualified Ident -> Expr
Var SourceSpan
ss forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QualifiedBy -> a -> Qualified a
Qualified QualifiedBy
ByNullSourcePos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(SourceSpan, Ident)]
args
binders :: [CaseAlternative]
binders = [ [Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder]
bs [GuardedExpr]
result | ([Binder]
bs, [GuardedExpr]
result) <- [([Binder], [GuardedExpr])]
alternatives ]
let value :: Expr
value = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Binder -> Expr -> Expr
Abs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SourceSpan -> Ident -> Binder
VarBinder) ([Expr] -> [CaseAlternative] -> Expr
Case [Expr]
vars [CaseAlternative]
binders) [(SourceSpan, Ident)]
args
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SourceAnn
-> Ident -> NameKind -> [Binder] -> [GuardedExpr] -> Declaration
ValueDecl (SourceSpan
ss, []) Ident
ident NameKind
Public [] [Expr -> GuardedExpr
MkUnguarded Expr
value]
where
findName :: Binder -> Maybe (SourceSpan, Ident)
findName :: Binder -> Maybe (SourceSpan, Ident)
findName (VarBinder SourceSpan
ss' Ident
name) = forall a. a -> Maybe a
Just (SourceSpan
ss', Ident
name)
findName (PositionedBinder SourceSpan
_ [Comment]
_ Binder
binder) = Binder -> Maybe (SourceSpan, Ident)
findName Binder
binder
findName Binder
_ = forall a. Maybe a
Nothing
allUnique :: (Ord a) => [a] -> Bool
allUnique :: forall a. Ord a => [a] -> Bool
allUnique [a]
xs = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Ord a => [a] -> [a]
ordNub [a]
xs)
argName :: Maybe (SourceSpan, Ident) -> m (SourceSpan, Ident)
argName :: Maybe (SourceSpan, Ident) -> m (SourceSpan, Ident)
argName (Just (SourceSpan
ss', Ident
name)) = forall (m :: * -> *) a. Monad m => a -> m a
return (SourceSpan
ss', Ident
name)
argName Maybe (SourceSpan, Ident)
_ = (SourceSpan
nullSourceSpan, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadSupply m => m Ident
freshIdent'
resolveNames :: [Maybe (SourceSpan, Ident)] -> [Maybe (SourceSpan, Ident)] -> [Maybe (SourceSpan, Ident)]
resolveNames :: [Maybe (SourceSpan, Ident)]
-> [Maybe (SourceSpan, Ident)] -> [Maybe (SourceSpan, Ident)]
resolveNames = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe (SourceSpan, Ident)
-> Maybe (SourceSpan, Ident) -> Maybe (SourceSpan, Ident)
resolveName
resolveName :: Maybe (SourceSpan, Ident) -> Maybe (SourceSpan, Ident) -> Maybe (SourceSpan, Ident)
resolveName :: Maybe (SourceSpan, Ident)
-> Maybe (SourceSpan, Ident) -> Maybe (SourceSpan, Ident)
resolveName (Just (SourceSpan, Ident)
a) (Just (SourceSpan, Ident)
b)
| (SourceSpan, Ident)
a forall a. Eq a => a -> a -> Bool
== (SourceSpan, Ident)
b = forall a. a -> Maybe a
Just (SourceSpan, Ident)
a
| Bool
otherwise = forall a. Maybe a
Nothing
resolveName Maybe (SourceSpan, Ident)
_ Maybe (SourceSpan, Ident)
_ = forall a. Maybe a
Nothing