{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
module Embedder.HSE.Desugar (desugar, addMainModuleHead) where

import ReWire.Annotation (Annote)
import ReWire.Error (MonadError, AstError, failAt)
import ReWire.HSE.Desugar
      ( Desugar (..), pass, Fresh, fresh, addMainModuleHead
      , desugarNegs, desugarDos, desugarInfix, flattenLambdas, depatLambdas
      , lambdasToCases, desugarGuards, desugarIfs, wheresToLets
      , desugarNegLitPats, normIds, deparenify, normTyContext, desugarTyFuns
      , desugarAsPats
      )
import ReWire.HSE.Rename (Renamer)
import ReWire.SYB (Tr (TM), transform)

import Control.Monad (replicateM, (>=>), void)
import Control.Monad.State (evalStateT, MonadState)
import Data.Foldable (foldrM)
import Data.Text (pack)
import Language.Haskell.Exts.Syntax

-- | Desugar into lambdas then normalize the lambdas. This differs from
--   ReWire.HSE.Desugar's pipeline: tuples, records, case flattening, and
--   discriminator lifting are deferred to the Atmo IR, and unguarded
--   multi-clause function bindings are kept intact (see 'desugarFuns').
desugar :: MonadError AstError m => Renamer -> Module Annote -> m (Module Annote)
desugar :: forall (m :: * -> *).
MonadError AstError m =>
Renamer -> Module Annote -> m (Module Annote)
desugar Renamer
_rn = (StateT Fresh m (Module Annote) -> Fresh -> m (Module Annote))
-> Fresh -> StateT Fresh m (Module Annote) -> m (Module Annote)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Fresh m (Module Annote) -> Fresh -> m (Module Annote)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Fresh
0 (StateT Fresh m (Module Annote) -> m (Module Annote))
-> (Module Annote -> StateT Fresh m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ( Module Annote -> StateT Fresh m (Module Annote)
forall a. a -> StateT Fresh m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Module Annote -> StateT Fresh m (Module Annote))
-> (Module Annote -> StateT Fresh m (Module Annote))
-> Module Annote
-> StateT Fresh m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Fresh m)
-> Module Annote -> StateT Fresh m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass Desugar (StateT Fresh m)
forall (m :: * -> *). MonadState Fresh m => Desugar m
desugarInfix
      (Module Annote -> StateT Fresh m (Module Annote))
-> (Module Annote -> StateT Fresh m (Module Annote))
-> Module Annote
-> StateT Fresh m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Fresh m)
-> Module Annote -> StateT Fresh m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass
            ( Desugar (StateT Fresh m)
forall (m :: * -> *). Monad m => Desugar m
desugarNegs
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
Desugar m
desugarDos
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *). MonadState Fresh m => Desugar m
desugarInfix
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
Desugar m
desugarFuns
            )
      (Module Annote -> StateT Fresh m (Module Annote))
-> (Module Annote -> StateT Fresh m (Module Annote))
-> Module Annote
-> StateT Fresh m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Fresh m)
-> Module Annote -> StateT Fresh m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass Desugar (StateT Fresh m)
forall (m :: * -> *). Monad m => Desugar m
flattenLambdas
      (Module Annote -> StateT Fresh m (Module Annote))
-> (Module Annote -> StateT Fresh m (Module Annote))
-> Module Annote
-> StateT Fresh m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Fresh m)
-> Module Annote -> StateT Fresh m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass
            ( Desugar (StateT Fresh m)
forall (m :: * -> *). MonadState Fresh m => Desugar m
depatLambdas
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *). Monad m => Desugar m
lambdasToCases
            )
      (Module Annote -> StateT Fresh m (Module Annote))
-> (Module Annote -> StateT Fresh m (Module Annote))
-> Module Annote
-> StateT Fresh m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Fresh m)
-> Module Annote -> StateT Fresh m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass Desugar (StateT Fresh m)
forall (m :: * -> *). MonadState Fresh m => Desugar m
desugarGuards
      (Module Annote -> StateT Fresh m (Module Annote))
-> (Module Annote -> StateT Fresh m (Module Annote))
-> Module Annote
-> StateT Fresh m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Fresh m)
-> Module Annote -> StateT Fresh m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass
            ( Desugar (StateT Fresh m)
forall (m :: * -> *). Monad m => Desugar m
desugarIfs
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *). MonadError AstError m => Desugar m
wheresToLets
            )
      (Module Annote -> StateT Fresh m (Module Annote))
-> (Module Annote -> StateT Fresh m (Module Annote))
-> Module Annote
-> StateT Fresh m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Fresh m)
-> Module Annote -> StateT Fresh m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass
            ( Desugar (StateT Fresh m)
forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
Desugar m
desugarLets
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *). Monad m => Desugar m
desugarNegLitPats
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *). Monad m => Desugar m
normIds
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *). Monad m => Desugar m
deparenify
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *). Monad m => Desugar m
normTyContext
           Desugar (StateT Fresh m)
-> Desugar (StateT Fresh m) -> Desugar (StateT Fresh m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Fresh m)
forall (m :: * -> *). Monad m => Desugar m
desugarTyFuns
            )
      (Module Annote -> StateT Fresh m (Module Annote))
-> (Module Annote -> StateT Fresh m (Module Annote))
-> Module Annote
-> StateT Fresh m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Fresh m)
-> Module Annote -> StateT Fresh m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass Desugar (StateT Fresh m)
forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
Desugar m
desugarAsPats
      )

-- | Like ReWire.HSE.Desugar's desugarFuns, except that unguarded multi-clause
--   function bindings are kept intact (Atmo represents them directly) and
--   pattern variables are annotated with their declared types. A binding
--   with a guarded clause still desugars to a single PatBind:
--
-- > f p1 p2 | g = rhs1
-- > f q1 q2 = rhs2
--
--   becomes
--
-- > f = \ $1 $2 -> case ($1, $2) of { (p1, p2) | g -> rhs1; (q1, q2) -> rhs2 }
desugarFuns :: (MonadState Fresh m, MonadError AstError m) => Desugar m
desugarFuns :: forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
Desugar m
desugarFuns = Desugar m
forall a. Monoid a => a
mempty
      { dsModule = TM $ \ case
            Module Annote
man Maybe (ModuleHead Annote)
hd [ModulePragma Annote]
prags [ImportDecl Annote]
imps [Decl Annote]
ds -> Annote
-> Maybe (ModuleHead Annote)
-> [ModulePragma Annote]
-> [ImportDecl Annote]
-> [Decl Annote]
-> Module Annote
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Module Annote
man Maybe (ModuleHead Annote)
hd [ModulePragma Annote]
prags [ImportDecl Annote]
imps ([Decl Annote] -> Module Annote)
-> m [Decl Annote] -> m (Module Annote)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl Annote -> m (Decl Annote))
-> [Decl Annote] -> m [Decl Annote]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote)
forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
[(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote)
desugarFun ([(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote))
-> [(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote)
forall a b. (a -> b) -> a -> b
$ [Decl Annote] -> [(Name Annote, Type Annote)]
tySigMap [Decl Annote]
ds) [Decl Annote]
ds
            Module Annote
m                           -> Module Annote -> m (Module Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Module Annote
m
      , dsBinds = TM $ \ case
            BDecls Annote
ban [Decl Annote]
ds               -> Annote -> [Decl Annote] -> Binds Annote
forall l. l -> [Decl l] -> Binds l
BDecls Annote
ban ([Decl Annote] -> Binds Annote)
-> m [Decl Annote] -> m (Binds Annote)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Decl Annote -> m (Decl Annote))
-> [Decl Annote] -> m [Decl Annote]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote)
forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
[(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote)
desugarFun ([(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote))
-> [(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote)
forall a b. (a -> b) -> a -> b
$ [Decl Annote] -> [(Name Annote, Type Annote)]
tySigMap [Decl Annote]
ds) [Decl Annote]
ds
            Binds Annote
b                           -> Binds Annote -> m (Binds Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Binds Annote
b
      }
      where desugarFun :: (MonadState Fresh m, MonadError AstError m) => [(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote)
            desugarFun :: forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
[(Name Annote, Type Annote)] -> Decl Annote -> m (Decl Annote)
desugarFun [(Name Annote, Type Annote)]
ts = \ case
                  FunBind Annote
l ms :: [Match Annote]
ms@(Match {}:[Match Annote]
_) | [Match Annote] -> Bool
forall l. [Match l] -> Bool
allUnguarded [Match Annote]
ms ->
                        Decl Annote -> m (Decl Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decl Annote -> m (Decl Annote)) -> Decl Annote -> m (Decl Annote)
forall a b. (a -> b) -> a -> b
$ Annote -> [Match Annote] -> Decl Annote
forall l. l -> [Match l] -> Decl l
FunBind Annote
l [Match Annote]
ms
                  FunBind Annote
l ms :: [Match Annote]
ms@(Match Annote
l' Name Annote
name [Pat Annote]
pats Rhs Annote
_ Maybe (Binds Annote)
_:[Match Annote]
_) -> do
                        alts <- (Match Annote -> m (Alt Annote))
-> [Match Annote] -> m [Alt Annote]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([(Name Annote, Type Annote)] -> Match Annote -> m (Alt Annote)
forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
[(Name Annote, Type Annote)] -> Match Annote -> m (Alt Annote)
toAlt [(Name Annote, Type Annote)]
ts) [Match Annote]
ms
                        e    <- buildLambda l alts $ length pats
                        pure $ PatBind l (PVar l' name) (UnGuardedRhs l e) Nothing
                  -- Turn guards on PatBind into guards on case (of unit) alts.
                  PatBind Annote
l Pat Annote
p rhs :: Rhs Annote
rhs@(GuardedRhss Annote
l' [GuardedRhs Annote]
_) Maybe (Binds Annote)
binds -> Decl Annote -> m (Decl Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decl Annote -> m (Decl Annote)) -> Decl Annote -> m (Decl Annote)
forall a b. (a -> b) -> a -> b
$ Annote
-> Pat Annote -> Rhs Annote -> Maybe (Binds Annote) -> Decl Annote
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Decl l
PatBind Annote
l Pat Annote
p (Annote -> Exp Annote -> Rhs Annote
forall l. l -> Exp l -> Rhs l
UnGuardedRhs Annote
l' (Exp Annote -> Rhs Annote) -> Exp Annote -> Rhs Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Exp Annote -> [Alt Annote] -> Exp Annote
forall l. l -> Exp l -> [Alt l] -> Exp l
Case Annote
l' (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Con Annote
l' (QName Annote -> Exp Annote) -> QName Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> SpecialCon Annote -> QName Annote
forall l. l -> SpecialCon l -> QName l
Special Annote
l' (SpecialCon Annote -> QName Annote)
-> SpecialCon Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> SpecialCon Annote
forall l. l -> SpecialCon l
UnitCon Annote
l') [Annote
-> Pat Annote -> Rhs Annote -> Maybe (Binds Annote) -> Alt Annote
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt Annote
l' (Annote -> Pat Annote
forall l. l -> Pat l
PWildCard Annote
l') Rhs Annote
rhs Maybe (Binds Annote)
binds]) Maybe (Binds Annote)
forall a. Maybe a
Nothing
                  Decl Annote
d                                        -> Decl Annote -> m (Decl Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Decl Annote
d

            buildLambda :: (MonadState Fresh m, MonadError AstError m) => Annote -> [Alt Annote] -> Int -> m (Exp Annote)
            buildLambda :: forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
Annote -> [Alt Annote] -> Fresh -> m (Exp Annote)
buildLambda Annote
l [Alt Annote]
alts = \ case
                  Fresh
1     -> do
                        x <- Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Fresh m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l
                        -- NOTE: can't type-annotate params without expanding type synonyms.
                        pure $ Lambda l [PVar l x] $ Case l (Var l $ UnQual l x) alts
                  Fresh
arity -> do
                        xs <- Fresh -> m (Name Annote) -> m [Name Annote]
forall (m :: * -> *) a. Applicative m => Fresh -> m a -> m [a]
replicateM Fresh
arity (Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Fresh m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l)
                        -- NOTE: can't type-annotate params without expanding type synonyms.
                        pure $ Lambda l (PVar l <$> xs) $ Case l (Tuple l Boxed (map (Var l . UnQual l) xs)) alts

            toAlt :: (MonadState Fresh m, MonadError AstError m) => [(Name Annote, Type Annote)] -> Match Annote -> m (Alt Annote)
            toAlt :: forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
[(Name Annote, Type Annote)] -> Match Annote -> m (Alt Annote)
toAlt [(Name Annote, Type Annote)]
ts = \ case
                  -- NOTE: can't type-annotate params without expanding type synonyms.
                  Match Annote
l' Name Annote
_ [Pat Annote
p] Rhs Annote
rhs Maybe (Binds Annote)
binds -> Alt Annote -> m (Alt Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Alt Annote -> m (Alt Annote)) -> Alt Annote -> m (Alt Annote)
forall a b. (a -> b) -> a -> b
$ Annote
-> Pat Annote -> Rhs Annote -> Maybe (Binds Annote) -> Alt Annote
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt Annote
l' ([(Name Annote, Type Annote)] -> Pat Annote -> Pat Annote
annotatePVars [(Name Annote, Type Annote)]
ts Pat Annote
p) Rhs Annote
rhs Maybe (Binds Annote)
binds
                  Match Annote
l' Name Annote
_ [Pat Annote]
ps  Rhs Annote
rhs Maybe (Binds Annote)
binds -> Alt Annote -> m (Alt Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Alt Annote -> m (Alt Annote)) -> Alt Annote -> m (Alt Annote)
forall a b. (a -> b) -> a -> b
$ Annote
-> Pat Annote -> Rhs Annote -> Maybe (Binds Annote) -> Alt Annote
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt Annote
l' (Annote -> Boxed -> [Pat Annote] -> Pat Annote
forall l. l -> Boxed -> [Pat l] -> Pat l
PTuple Annote
l' Boxed
Boxed ([Pat Annote] -> Pat Annote) -> [Pat Annote] -> Pat Annote
forall a b. (a -> b) -> a -> b
$ (Pat Annote -> Pat Annote) -> [Pat Annote] -> [Pat Annote]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name Annote, Type Annote)] -> Pat Annote -> Pat Annote
annotatePVars [(Name Annote, Type Annote)]
ts) [Pat Annote]
ps) Rhs Annote
rhs Maybe (Binds Annote)
binds
                  Match Annote
m                        -> Annote -> Text -> m (Alt Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Match Annote -> Annote
forall l. Match l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Match Annote
m) (Text -> m (Alt Annote)) -> Text -> m (Alt Annote)
forall a b. (a -> b) -> a -> b
$ Text
"Unsupported decl syntax: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Match () -> String
forall a. Show a => a -> String
show (Match () -> String) -> Match () -> String
forall a b. (a -> b) -> a -> b
$ Match Annote -> Match ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Match Annote
m)

            allUnguarded :: [Match l] -> Bool
            allUnguarded :: forall l. [Match l] -> Bool
allUnguarded [] = Bool
True
            allUnguarded (Match l
_ Name l
_ [Pat l]
_ (UnGuardedRhs {}) Maybe (Binds l)
_ : [Match l]
ms) = [Match l] -> Bool
forall l. [Match l] -> Bool
allUnguarded [Match l]
ms
            allUnguarded (Match l
_ Name l
_ [Pat l]
_ (GuardedRhss {}) Maybe (Binds l)
_ : [Match l]
_) = Bool
False
            allUnguarded [Match l]
_ = String -> Bool
forall a. HasCallStack => String -> a
error String
"Infix should be desugared by now."

-- TODO(chathhorn): recursive bindings?
-- | Like ReWire.HSE.Desugar's desugarLets, but annotates pattern variables with
--   their declared types. Turns Lets into Cases. Assumes functions in Lets
--   are already desugared. E.g.:
--
-- > let p = e1
-- >     q = e2
-- > in e3
--
--   becomes
--
-- > case e1 of { p -> (case e2 of { q -> e3 } }
desugarLets :: (MonadState Fresh m, MonadError AstError m) => Desugar m
desugarLets :: forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
Desugar m
desugarLets = Desugar m
forall a. Monoid a => a
mempty { dsExp = TM $ \ case
      Let Annote
_ (BDecls Annote
_ [Decl Annote]
ds) Exp Annote
e -> (Decl Annote -> Exp Annote -> m (Exp Annote))
-> Exp Annote -> [Decl Annote] -> m (Exp Annote)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM ([(Name Annote, Type Annote)]
-> Decl Annote -> Exp Annote -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
[(Name Annote, Type Annote)]
-> Decl Annote -> Exp Annote -> m (Exp Annote)
transLet ([(Name Annote, Type Annote)]
 -> Decl Annote -> Exp Annote -> m (Exp Annote))
-> [(Name Annote, Type Annote)]
-> Decl Annote
-> Exp Annote
-> m (Exp Annote)
forall a b. (a -> b) -> a -> b
$ [Decl Annote] -> [(Name Annote, Type Annote)]
tySigMap [Decl Annote]
ds) Exp Annote
e ([Decl Annote] -> m (Exp Annote))
-> [Decl Annote] -> m (Exp Annote)
forall a b. (a -> b) -> a -> b
$ (Decl Annote -> Bool) -> [Decl Annote] -> [Decl Annote]
forall a. (a -> Bool) -> [a] -> [a]
filter Decl Annote -> Bool
isPatBind [Decl Annote]
ds
      n :: Exp Annote
n@Let{}               -> Annote -> Text -> m (Exp Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Exp Annote -> Annote
forall l. Exp l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Exp Annote
n) Text
"Unsupported let syntax"
      Exp Annote
e                     -> Exp Annote -> m (Exp Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp Annote
e}
      where transLet :: (MonadState Fresh m, MonadError AstError m) => [(Name Annote, Type Annote)] -> Decl Annote -> Exp Annote -> m (Exp Annote)
            transLet :: forall (m :: * -> *).
(MonadState Fresh m, MonadError AstError m) =>
[(Name Annote, Type Annote)]
-> Decl Annote -> Exp Annote -> m (Exp Annote)
transLet [(Name Annote, Type Annote)]
ts (PatBind Annote
l Pat Annote
p (UnGuardedRhs Annote
l' Exp Annote
e1) Maybe (Binds Annote)
Nothing) Exp Annote
inner = Exp Annote -> m (Exp Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp Annote -> m (Exp Annote)) -> Exp Annote -> m (Exp Annote)
forall a b. (a -> b) -> a -> b
$ Annote -> Exp Annote -> [Alt Annote] -> Exp Annote
forall l. l -> Exp l -> [Alt l] -> Exp l
Case Annote
l Exp Annote
e1 [Annote
-> Pat Annote -> Rhs Annote -> Maybe (Binds Annote) -> Alt Annote
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt Annote
l ([(Name Annote, Type Annote)] -> Pat Annote -> Pat Annote
annotatePVars [(Name Annote, Type Annote)]
ts Pat Annote
p) (Annote -> Exp Annote -> Rhs Annote
forall l. l -> Exp l -> Rhs l
UnGuardedRhs Annote
l' Exp Annote
inner) Maybe (Binds Annote)
forall a. Maybe a
Nothing]
            transLet [(Name Annote, Type Annote)]
_ Decl Annote
n Exp Annote
_                                               = Annote -> Text -> m (Exp Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Decl Annote -> Annote
forall l. Decl l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Decl Annote
n) Text
"Unsupported syntax in a let binding"

            isPatBind :: Decl Annote -> Bool
            isPatBind :: Decl Annote -> Bool
isPatBind PatBind {} = Bool
True
            isPatBind Decl Annote
_          = Bool
False

tySigMap :: [Decl Annote] -> [(Name Annote, Type Annote)]
tySigMap :: [Decl Annote] -> [(Name Annote, Type Annote)]
tySigMap = (Decl Annote -> [(Name Annote, Type Annote)])
-> [Decl Annote] -> [(Name Annote, Type Annote)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl Annote -> [(Name Annote, Type Annote)]
tySig
      where tySig :: Decl Annote -> [(Name Annote, Type Annote)]
            tySig :: Decl Annote -> [(Name Annote, Type Annote)]
tySig = \ case
                  TypeSig Annote
_ [Name Annote]
ns Type Annote
t -> (,Type Annote
t) (Name Annote -> (Name Annote, Type Annote))
-> [Name Annote] -> [(Name Annote, Type Annote)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name Annote]
ns
                  Decl Annote
_              -> []

annotatePVars :: [(Name Annote, Type Annote)] -> Pat Annote -> Pat Annote
annotatePVars :: [(Name Annote, Type Annote)] -> Pat Annote -> Pat Annote
annotatePVars [(Name Annote, Type Annote)]
ts = (Pat Annote -> Pat Annote) -> Pat Annote -> Pat Annote
forall a b. (Data a, Data b) => (a -> a) -> b -> b
transform ((Pat Annote -> Pat Annote) -> Pat Annote -> Pat Annote)
-> (Pat Annote -> Pat Annote) -> Pat Annote -> Pat Annote
forall a b. (a -> b) -> a -> b
$ \ case
      PVar Annote
an Name Annote
n | Just Type Annote
t <- Name Annote -> [(Name Annote, Type Annote)] -> Maybe (Type Annote)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name Annote
n [(Name Annote, Type Annote)]
ts -> Annote -> Pat Annote -> Type Annote -> Pat Annote
forall l. l -> Pat l -> Type l -> Pat l
PatTypeSig Annote
an (Annote -> Name Annote -> Pat Annote
forall l. l -> Name l -> Pat l
PVar Annote
an Name Annote
n) Type Annote
t
      Pat Annote
n                                 -> Pat Annote
n