-- |
-- This module implements the desugaring pass which replaces patterns in let-in
-- expressions with appropriate case expressions.
--
module Language.PureScript.Sugar.LetPattern (desugarLetPatternModule) where

import Prelude

import Data.List (groupBy)
import Data.Function (on)

import Language.PureScript.AST (Binder, CaseAlternative(..), Declaration(..), Expr(..), pattern MkUnguarded, Module(..), SourceAnn, WhereProvenance, everywhereOnValues)
import Language.PureScript.Crash (internalError)

-- | Replace every @BoundValueDeclaration@ in @Let@ expressions with @Case@
-- expressions.
desugarLetPatternModule :: Module -> Module
desugarLetPatternModule :: Module -> Module
desugarLetPatternModule (Module SourceSpan
ss [Comment]
coms ModuleName
mn [Declaration]
ds Maybe [DeclarationRef]
exts) = SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
mn (forall a b. (a -> b) -> [a] -> [b]
map Declaration -> Declaration
desugarLetPattern [Declaration]
ds) Maybe [DeclarationRef]
exts

-- | Desugar a single let expression
desugarLetPattern :: Declaration -> Declaration
desugarLetPattern :: Declaration -> Declaration
desugarLetPattern Declaration
decl =
  let (Declaration -> Declaration
f, Expr -> Expr
_, Binder -> Binder
_) = (Declaration -> Declaration)
-> (Expr -> Expr)
-> (Binder -> Binder)
-> (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
everywhereOnValues forall a. a -> a
id Expr -> Expr
replace forall a. a -> a
id
  in Declaration -> Declaration
f Declaration
decl
  where
  replace :: Expr -> Expr
  replace :: Expr -> Expr
replace (Let WhereProvenance
w [Declaration]
ds Expr
e) = WhereProvenance
-> [Either [Declaration] (SourceAnn, Binder, Expr)] -> Expr -> Expr
go WhereProvenance
w ([Declaration] -> [Either [Declaration] (SourceAnn, Binder, Expr)]
partitionDecls [Declaration]
ds) Expr
e
  replace Expr
other = Expr
other

  go :: WhereProvenance
          -- Metadata about whether the let-in was a where clause
     -> [Either [Declaration] (SourceAnn, Binder, Expr)]
          -- Declarations to desugar
     -> Expr
          -- The original let-in result expression
     -> Expr
  go :: WhereProvenance
-> [Either [Declaration] (SourceAnn, Binder, Expr)] -> Expr -> Expr
go WhereProvenance
_ [] Expr
e = Expr
e
  go WhereProvenance
w (Right ((SourceSpan
pos, [Comment]
com), Binder
binder, Expr
boundE) : [Either [Declaration] (SourceAnn, Binder, Expr)]
ds) Expr
e =
    SourceSpan -> [Comment] -> Expr -> Expr
PositionedValue SourceSpan
pos [Comment]
com forall a b. (a -> b) -> a -> b
$ [Expr] -> [CaseAlternative] -> Expr
Case [Expr
boundE] [[Binder] -> [GuardedExpr] -> CaseAlternative
CaseAlternative [Binder
binder] [Expr -> GuardedExpr
MkUnguarded forall a b. (a -> b) -> a -> b
$ WhereProvenance
-> [Either [Declaration] (SourceAnn, Binder, Expr)] -> Expr -> Expr
go WhereProvenance
w [Either [Declaration] (SourceAnn, Binder, Expr)]
ds Expr
e]]
  go WhereProvenance
w (Left [Declaration]
ds:[Either [Declaration] (SourceAnn, Binder, Expr)]
dss) Expr
e = WhereProvenance -> [Declaration] -> Expr -> Expr
Let WhereProvenance
w [Declaration]
ds (WhereProvenance
-> [Either [Declaration] (SourceAnn, Binder, Expr)] -> Expr -> Expr
go WhereProvenance
w [Either [Declaration] (SourceAnn, Binder, Expr)]
dss Expr
e)

partitionDecls :: [Declaration] -> [Either [Declaration] (SourceAnn, Binder, Expr)]
partitionDecls :: [Declaration] -> [Either [Declaration] (SourceAnn, Binder, Expr)]
partitionDecls = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Declaration] -> [Either [Declaration] (SourceAnn, Binder, Expr)]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Declaration -> Bool
isBoundValueDeclaration)
  where
    f :: [Declaration] -> [Either [Declaration] (SourceAnn, Binder, Expr)]
f ds :: [Declaration]
ds@(Declaration
d:[Declaration]
_)
      | Declaration -> Bool
isBoundValueDeclaration Declaration
d = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Declaration -> (SourceAnn, Binder, Expr)
g) [Declaration]
ds
    f [Declaration]
ds = [forall a b. a -> Either a b
Left [Declaration]
ds]

    g :: Declaration -> (SourceAnn, Binder, Expr)
g (BoundValueDeclaration SourceAnn
sa Binder
binder Expr
expr) = (SourceAnn
sa, Binder
binder, Expr
expr)
    g Declaration
_ = forall a. HasCallStack => String -> a
internalError String
"partitionDecls: the impossible happened."

isBoundValueDeclaration :: Declaration -> Bool
isBoundValueDeclaration :: Declaration -> Bool
isBoundValueDeclaration BoundValueDeclaration{} = Bool
True
isBoundValueDeclaration Declaration
_ = Bool
False