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 (MonadSupply)
import Language.PureScript.AST
import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment (NameKind(..))
import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..), addHint, errorMessage', parU, rethrow, withPosition)
import Language.PureScript.Names (pattern ByNullSourcePos, Ident, Qualified(..), freshIdent')
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