{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
module ReWire.HSE.Desugar
      ( desugar, addMainModuleHead
      -- | The 'Desugar' machinery and individual sub-passes, exported so
      --   that Embedder.HSE.Desugar can compose its own desugaring
      --   pipeline.
      , Desugar (..), pass, Fresh, fresh, err, mkTuple
      , desugarRecords, normIds, deparenify, desugarInfix, desugarNegLitPats
      , desugarTuples, desugarFuns, liftDiscriminator, flattenAlts
      , desugarGuards, wheresToLets, desugarDos, normTyContext, desugarTyFuns
      , desugarLets, desugarIfs, desugarNegs, flattenLambdas, depatLambdas
      , desugarAsPats, lambdasToCases
      ) where

import ReWire.Annotation (noAnn, Annote (..))
import ReWire.Error (MonadError, AstError, failAt)
import ReWire.HSE.Rename (Renamer, FQName, CtorSigs, qnamish, name, Namespace (Value), rename, getLocalCtorSigs, lookupCtorSig, findCtorSigFromField)
import ReWire.SYB (Tr (TId, TM, T), transformTr, transform, transformM, query)

import Control.Monad (replicateM, (>=>), void, when, msum, unless)
import Control.Monad.State (evalStateT, MonadState (..), modify)
import Data.Foldable (foldrM)
import Data.Map.Strict (Map)
import Data.Maybe (isNothing, mapMaybe)
import Data.Text (pack)
import Language.Haskell.Exts.Pretty (prettyPrint)
import Language.Haskell.Exts.Syntax

import qualified Data.Map.Strict as Map

data Desugar m = Desugar
      { forall (m :: * -> *). Desugar m -> Tr m (Module Annote)
dsModule   :: Tr m (Module Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (Pat Annote)
dsPat      :: Tr m (Pat Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (ConDecl Annote)
dsConDecl  :: Tr m (ConDecl Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (Exp Annote)
dsExp      :: Tr m (Exp Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (Type Annote)
dsType     :: Tr m (Type Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (DeclHead Annote)
dsDeclHead :: Tr m (DeclHead Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (Binds Annote)
dsBinds    :: Tr m (Binds Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (Match Annote)
dsMatch    :: Tr m (Match Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (Alt Annote)
dsAlt      :: Tr m (Alt Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (QName Annote)
dsQName    :: Tr m (QName Annote)
      , forall (m :: * -> *). Desugar m -> Tr m (Decl Annote)
dsDecl     :: Tr m (Decl Annote)
      }

instance Monad m => Semigroup (Desugar m) where
      <> :: Desugar m -> Desugar m -> Desugar m
(<>) (Desugar Tr m (Module Annote)
f1 Tr m (Pat Annote)
f2 Tr m (ConDecl Annote)
f3 Tr m (Exp Annote)
f4 Tr m (Type Annote)
f5 Tr m (DeclHead Annote)
f6 Tr m (Binds Annote)
f7 Tr m (Match Annote)
f8 Tr m (Alt Annote)
f9 Tr m (QName Annote)
f10 Tr m (Decl Annote)
f11)
           (Desugar Tr m (Module Annote)
g1 Tr m (Pat Annote)
g2 Tr m (ConDecl Annote)
g3 Tr m (Exp Annote)
g4 Tr m (Type Annote)
g5 Tr m (DeclHead Annote)
g6 Tr m (Binds Annote)
g7 Tr m (Match Annote)
g8 Tr m (Alt Annote)
g9 Tr m (QName Annote)
g10 Tr m (Decl Annote)
g11)
            = Tr m (Module Annote)
-> Tr m (Pat Annote)
-> Tr m (ConDecl Annote)
-> Tr m (Exp Annote)
-> Tr m (Type Annote)
-> Tr m (DeclHead Annote)
-> Tr m (Binds Annote)
-> Tr m (Match Annote)
-> Tr m (Alt Annote)
-> Tr m (QName Annote)
-> Tr m (Decl Annote)
-> Desugar m
forall (m :: * -> *).
Tr m (Module Annote)
-> Tr m (Pat Annote)
-> Tr m (ConDecl Annote)
-> Tr m (Exp Annote)
-> Tr m (Type Annote)
-> Tr m (DeclHead Annote)
-> Tr m (Binds Annote)
-> Tr m (Match Annote)
-> Tr m (Alt Annote)
-> Tr m (QName Annote)
-> Tr m (Decl Annote)
-> Desugar m
Desugar (Tr m (Module Annote)
f1  Tr m (Module Annote)
-> Tr m (Module Annote) -> Tr m (Module Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (Module Annote)
g1)
                      (Tr m (Pat Annote)
f2  Tr m (Pat Annote) -> Tr m (Pat Annote) -> Tr m (Pat Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (Pat Annote)
g2)
                      (Tr m (ConDecl Annote)
f3  Tr m (ConDecl Annote)
-> Tr m (ConDecl Annote) -> Tr m (ConDecl Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (ConDecl Annote)
g3)
                      (Tr m (Exp Annote)
f4  Tr m (Exp Annote) -> Tr m (Exp Annote) -> Tr m (Exp Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (Exp Annote)
g4)
                      (Tr m (Type Annote)
f5  Tr m (Type Annote) -> Tr m (Type Annote) -> Tr m (Type Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (Type Annote)
g5)
                      (Tr m (DeclHead Annote)
f6  Tr m (DeclHead Annote)
-> Tr m (DeclHead Annote) -> Tr m (DeclHead Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (DeclHead Annote)
g6)
                      (Tr m (Binds Annote)
f7  Tr m (Binds Annote) -> Tr m (Binds Annote) -> Tr m (Binds Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (Binds Annote)
g7)
                      (Tr m (Match Annote)
f8  Tr m (Match Annote) -> Tr m (Match Annote) -> Tr m (Match Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (Match Annote)
g8)
                      (Tr m (Alt Annote)
f9  Tr m (Alt Annote) -> Tr m (Alt Annote) -> Tr m (Alt Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (Alt Annote)
g9)
                      (Tr m (QName Annote)
f10 Tr m (QName Annote) -> Tr m (QName Annote) -> Tr m (QName Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (QName Annote)
g10)
                      (Tr m (Decl Annote)
f11 Tr m (Decl Annote) -> Tr m (Decl Annote) -> Tr m (Decl Annote)
forall a. Semigroup a => a -> a -> a
<> Tr m (Decl Annote)
g11)

instance Monad m => Monoid (Desugar m) where
      mempty :: Desugar m
mempty = Tr m (Module Annote)
-> Tr m (Pat Annote)
-> Tr m (ConDecl Annote)
-> Tr m (Exp Annote)
-> Tr m (Type Annote)
-> Tr m (DeclHead Annote)
-> Tr m (Binds Annote)
-> Tr m (Match Annote)
-> Tr m (Alt Annote)
-> Tr m (QName Annote)
-> Tr m (Decl Annote)
-> Desugar m
forall (m :: * -> *).
Tr m (Module Annote)
-> Tr m (Pat Annote)
-> Tr m (ConDecl Annote)
-> Tr m (Exp Annote)
-> Tr m (Type Annote)
-> Tr m (DeclHead Annote)
-> Tr m (Binds Annote)
-> Tr m (Match Annote)
-> Tr m (Alt Annote)
-> Tr m (QName Annote)
-> Tr m (Decl Annote)
-> Desugar m
Desugar Tr m (Module Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (Pat Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (ConDecl Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (Exp Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (Type Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (DeclHead Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (Binds Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (Match Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (Alt Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (QName Annote)
forall (m :: * -> *) a. Tr m a
TId Tr m (Decl Annote)
forall (m :: * -> *) a. Tr m a
TId

pass :: Monad m => Desugar m -> Module Annote -> m (Module Annote)
pass :: forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass (Desugar Tr m (Module Annote)
f1 Tr m (Pat Annote)
f2 Tr m (ConDecl Annote)
f3 Tr m (Exp Annote)
f4 Tr m (Type Annote)
f5 Tr m (DeclHead Annote)
f6 Tr m (Binds Annote)
f7 Tr m (Match Annote)
f8 Tr m (Alt Annote)
f9 Tr m (QName Annote)
f10 Tr m (Decl Annote)
f11)
      =   Tr m (Decl Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (Decl Annote)
f11
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (QName Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (QName Annote)
f10
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (Alt Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (Alt Annote)
f9
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (Match Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (Match Annote)
f8
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (Binds Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (Binds Annote)
f7
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (DeclHead Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (DeclHead Annote)
f6
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (Type Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (Type Annote)
f5
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (Exp Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (Exp Annote)
f4
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (ConDecl Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (ConDecl Annote)
f3
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (Pat Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (Pat Annote)
f2
      (Module Annote -> m (Module Annote))
-> (Module Annote -> m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tr m (Module Annote) -> Module Annote -> m (Module Annote)
forall a b (m :: * -> *).
(Data a, Data b, Monad m) =>
Tr m a -> b -> m b
transformTr Tr m (Module Annote)
f1

-- | Adds the "module Main where" if no module given (but not the "main"
--   export).
addMainModuleHead :: Module a -> Module a
addMainModuleHead :: forall a. Module a -> Module a
addMainModuleHead = \ case
      Module a
l Maybe (ModuleHead a)
Nothing [ModulePragma a]
ps [ImportDecl a]
imps [Decl a]
ds -> a
-> Maybe (ModuleHead a)
-> [ModulePragma a]
-> [ImportDecl a]
-> [Decl a]
-> Module a
forall l.
l
-> Maybe (ModuleHead l)
-> [ModulePragma l]
-> [ImportDecl l]
-> [Decl l]
-> Module l
Module a
l (ModuleHead a -> Maybe (ModuleHead a)
forall a. a -> Maybe a
Just (ModuleHead a -> Maybe (ModuleHead a))
-> ModuleHead a -> Maybe (ModuleHead a)
forall a b. (a -> b) -> a -> b
$ a
-> ModuleName a
-> Maybe (WarningText a)
-> Maybe (ExportSpecList a)
-> ModuleHead a
forall l.
l
-> ModuleName l
-> Maybe (WarningText l)
-> Maybe (ExportSpecList l)
-> ModuleHead l
ModuleHead a
l (a -> String -> ModuleName a
forall l. l -> String -> ModuleName l
ModuleName a
l String
"Main") Maybe (WarningText a)
forall a. Maybe a
Nothing (Maybe (ExportSpecList a) -> ModuleHead a)
-> Maybe (ExportSpecList a) -> ModuleHead a
forall a b. (a -> b) -> a -> b
$ ExportSpecList a -> Maybe (ExportSpecList a)
forall a. a -> Maybe a
Just (ExportSpecList a -> Maybe (ExportSpecList a))
-> ExportSpecList a -> Maybe (ExportSpecList a)
forall a b. (a -> b) -> a -> b
$ a -> [ExportSpec a] -> ExportSpecList a
forall l. l -> [ExportSpec l] -> ExportSpecList l
ExportSpecList a
l []) [ModulePragma a]
ps [ImportDecl a]
imps [Decl a]
ds
      Module a
m                           -> Module a
m

-- | Desugar into lambdas then normalize the lambdas.
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 Int m (Module Annote) -> Int -> m (Module Annote))
-> Int -> StateT Int m (Module Annote) -> m (Module Annote)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Int m (Module Annote) -> Int -> m (Module Annote)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Int
0 (StateT Int m (Module Annote) -> m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> m (Module Annote)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ( Module Annote -> StateT Int m (Module Annote)
forall a. a -> StateT Int m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass Desugar (StateT Int m)
forall (m :: * -> *). MonadState Int m => Desugar m
desugarInfix
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass
            ( Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
desugarNegs
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Desugar m
desugarDos
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). MonadState Int m => Desugar m
desugarInfix
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Desugar m
desugarFuns
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Renamer -> Desugar (StateT Int m)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Renamer -> Desugar m
desugarRecords Renamer
rn
            )
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
flattenLambdas
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass
            ( Desugar (StateT Int m)
forall (m :: * -> *). MonadState Int m => Desugar m
depatLambdas
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
lambdasToCases
            )
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
flattenAlts
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass Desugar (StateT Int m)
forall (m :: * -> *). MonadState Int m => Desugar m
desugarGuards
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass
            ( Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
desugarIfs
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). MonadError AstError m => Desugar m
wheresToLets
            )
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass
            ( Desugar (StateT Int m)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Desugar m
desugarLets
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
desugarNegLitPats
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
desugarTuples
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
normIds
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
deparenify
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
normTyContext
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
desugarTyFuns
            )
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass Desugar (StateT Int m)
forall (m :: * -> *). Monad m => Desugar m
flattenAlts -- again
      (Module Annote -> StateT Int m (Module Annote))
-> (Module Annote -> StateT Int m (Module Annote))
-> Module Annote
-> StateT Int m (Module Annote)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Desugar (StateT Int m)
-> Module Annote -> StateT Int m (Module Annote)
forall (m :: * -> *).
Monad m =>
Desugar m -> Module Annote -> m (Module Annote)
pass
            ( Desugar (StateT Int m)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Desugar m
desugarAsPats
           Desugar (StateT Int m)
-> Desugar (StateT Int m) -> Desugar (StateT Int m)
forall a. Semigroup a => a -> a -> a
<> Desugar (StateT Int m)
forall (m :: * -> *). MonadState Int m => Desugar m
liftDiscriminator
            )
      )

type Fresh = Int

fresh :: (MonadState Fresh m, Monad m) => Annote -> m (Name Annote)
fresh :: forall (m :: * -> *).
(MonadState Int m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l = do
      x <- m Int
forall s (m :: * -> *). MonadState s m => m s
get
      modify (+ 1)
      pure $ Ident l $ "$" <> show x

-- | record ctor name |-> (field, field place, ctor arity)
type FieldInfo = (Name Annote, (Name Annote, Type Annote, Int, Int))

-- | Desugar record type defs, field accessors, record patterns, record
--   construction expressions, and record update syntax.
--
-- > R {f = a}
--
-- becomes
--
-- > R _ a _
--
-- and
--
-- > r { f = a }
--
-- becomes
--
-- > case r of R x0 _ x1 -> R x0 a x1
desugarRecords :: (MonadState Fresh m, MonadError AstError m) => Renamer -> Desugar m
desugarRecords :: forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Renamer -> Desugar m
desugarRecords Renamer
rn = Desugar m
forall a. Monoid a => a
mempty
      { dsModule = TM $ \ case
            Module Annote
l Maybe (ModuleHead Annote)
h [ModulePragma Annote]
p [ImportDecl Annote]
imps [Decl Annote]
decls -> do
                  let fs :: [FieldInfo]
fs = ((Name (), [(Name (), Type ())]) -> [FieldInfo])
-> [(Name (), [(Name (), Type ())])] -> [FieldInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name (), [(Name (), Type ())]) -> [FieldInfo]
fieldInfo ([(Name (), [(Name (), Type ())])] -> [FieldInfo])
-> [(Name (), [(Name (), Type ())])] -> [FieldInfo]
forall a b. (a -> b) -> a -> b
$ Map (Name ()) [(Name (), Type ())]
-> [(Name (), [(Name (), Type ())])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (Name ()) [(Name (), Type ())]
 -> [(Name (), [(Name (), Type ())])])
-> Map (Name ()) [(Name (), Type ())]
-> [(Name (), [(Name (), Type ())])]
forall a b. (a -> b) -> a -> b
$ CtorSigs -> Map (Name ()) [(Name (), Type ())]
filterRecords (CtorSigs -> Map (Name ()) [(Name (), Type ())])
-> CtorSigs -> Map (Name ()) [(Name (), Type ())]
forall a b. (a -> b) -> a -> b
$ Renamer -> CtorSigs
getLocalCtorSigs Renamer
rn
                  ds <- ((Decl Annote, Decl Annote) -> [Decl Annote])
-> [(Decl Annote, Decl Annote)] -> [Decl Annote]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Decl Annote, Decl Annote) -> [Decl Annote]
forall a. (a, a) -> [a]
tupList ([(Decl Annote, Decl Annote)] -> [Decl Annote])
-> m [(Decl Annote, Decl Annote)] -> m [Decl Annote]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldInfo -> m (Decl Annote, Decl Annote))
-> [FieldInfo] -> m [(Decl Annote, 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 FieldInfo -> m (Decl Annote, Decl Annote)
forall (m :: * -> *).
MonadState Int m =>
FieldInfo -> m (Decl Annote, Decl Annote)
fieldDecl [FieldInfo]
fs
                  pure $ Module l h p imps (decls <> ds)
            Module Annote
e                       -> Module Annote -> m (Module Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Module Annote
e
      , dsPat = TM $ \ case
            PRec Annote
l QName Annote
c [PatField Annote]
fpats -> do
                  let sig :: [(Maybe FQName, Type ())]
sig  = Renamer -> FQName -> [(Maybe FQName, Type ())]
forall a. QNamish a => Renamer -> a -> [(Maybe FQName, Type ())]
lookupCtorSig Renamer
rn (Namespace -> Renamer -> QName Annote -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
c :: FQName)
                  let flds :: [FQName]
flds = ((Maybe FQName, Type ()) -> Maybe FQName)
-> [(Maybe FQName, Type ())] -> [FQName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe FQName, Type ()) -> Maybe FQName
forall a b. (a, b) -> a
fst [(Maybe FQName, Type ())]
sig
                  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PatField Annote]
fpats [PatField Annote] -> [PatField Annote] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& Bool -> Bool
not ([(Maybe FQName, Type ())] -> Bool
forall a t. [(Maybe a, t)] -> Bool
isRecordSig [(Maybe FQName, Type ())]
sig)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Record pattern found, but not a record"
                  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((PatField Annote -> Bool) -> [PatField Annote] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([FQName]
-> (PatField Annote -> Maybe FQName) -> PatField Annote -> Bool
forall a. [FQName] -> (a -> Maybe FQName) -> a -> Bool
inSig [FQName]
flds PatField Annote -> Maybe FQName
pfToField) [PatField Annote]
fpats)   (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Field pattern for nonexistent field"
                  Pat Annote -> m (Pat Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat Annote -> m (Pat Annote)) -> Pat Annote -> m (Pat Annote)
forall a b. (a -> b) -> a -> b
$ Annote -> QName Annote -> [Pat Annote] -> Pat Annote
forall l. l -> QName l -> [Pat l] -> Pat l
PApp Annote
l QName Annote
c ([Pat Annote] -> Pat Annote) -> [Pat Annote] -> Pat Annote
forall a b. (a -> b) -> a -> b
$ (FQName -> Pat Annote) -> [FQName] -> [Pat Annote]
forall a b. (a -> b) -> [a] -> [b]
map (Annote -> [PatField Annote] -> FQName -> Pat Annote
toPat Annote
l [PatField Annote]
fpats) [FQName]
flds
            Pat Annote
e              -> Pat Annote -> m (Pat Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat Annote
e

      , dsConDecl = T $ \ case
            RecDecl Annote
l Name Annote
n [FieldDecl Annote]
fs -> Annote -> Name Annote -> [Type Annote] -> ConDecl Annote
forall l. l -> Name l -> [Type l] -> ConDecl l
ConDecl Annote
l Name Annote
n ([Type Annote] -> ConDecl Annote)
-> [Type Annote] -> ConDecl Annote
forall a b. (a -> b) -> a -> b
$ (FieldDecl Annote -> Type Annote)
-> [FieldDecl Annote] -> [Type Annote]
forall a b. (a -> b) -> [a] -> [b]
map (\ (FieldDecl Annote
_ [Name Annote]
_ Type Annote
t) -> Type Annote
t) ([FieldDecl Annote] -> [Type Annote])
-> [FieldDecl Annote] -> [Type Annote]
forall a b. (a -> b) -> a -> b
$ (FieldDecl Annote -> [FieldDecl Annote])
-> [FieldDecl Annote] -> [FieldDecl Annote]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FieldDecl Annote -> [FieldDecl Annote]
flatten [FieldDecl Annote]
fs
            ConDecl Annote
e              -> ConDecl Annote
e
      , dsExp = TM $ \ case
            -- R { b = e } becomes R undefined e undefined
            RecConstr Annote
l QName Annote
c [FieldUpdate Annote]
fups -> do
                  let sig :: [(Maybe FQName, Type ())]
sig  = Renamer -> FQName -> [(Maybe FQName, Type ())]
forall a. QNamish a => Renamer -> a -> [(Maybe FQName, Type ())]
lookupCtorSig Renamer
rn (Namespace -> Renamer -> QName Annote -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
c :: FQName)
                  let flds :: [FQName]
flds = ((Maybe FQName, Type ()) -> Maybe FQName)
-> [(Maybe FQName, Type ())] -> [FQName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe FQName, Type ()) -> Maybe FQName
forall a b. (a, b) -> a
fst [(Maybe FQName, Type ())]
sig
                  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FieldUpdate Annote]
fups [FieldUpdate Annote] -> [FieldUpdate Annote] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& Bool -> Bool
not ([(Maybe FQName, Type ())] -> Bool
forall a t. [(Maybe a, t)] -> Bool
isRecordSig [(Maybe FQName, Type ())]
sig)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Record constructor found, but not a record"
                  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((FieldUpdate Annote -> Bool) -> [FieldUpdate Annote] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([FQName]
-> (FieldUpdate Annote -> Maybe FQName)
-> FieldUpdate Annote
-> Bool
forall a. [FQName] -> (a -> Maybe FQName) -> a -> Bool
inSig [FQName]
flds FieldUpdate Annote -> Maybe FQName
fupToField) [FieldUpdate Annote]
fups)  (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Annote -> Text -> m ()
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Field initializer for nonexistent field"
                  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
$ (Exp Annote -> Exp Annote -> Exp Annote)
-> Exp Annote -> [Exp Annote] -> Exp Annote
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l) (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Con Annote
l QName Annote
c) ([Exp Annote] -> Exp Annote) -> [Exp Annote] -> Exp Annote
forall a b. (a -> b) -> a -> b
$ (FQName -> Exp Annote) -> [FQName] -> [Exp Annote]
forall a b. (a -> b) -> [a] -> [b]
map (Annote -> [FieldUpdate Annote] -> FQName -> Exp Annote
toExp Annote
l [FieldUpdate Annote]
fups) [FQName]
flds
            RecUpdate Annote
l Exp Annote
_ [] -> Annote -> Text -> m (Exp Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Empty record update"
            -- r { b = e } becomes case r of { R x1 _ x2 -> R x1 e x2 }
            RecUpdate Annote
l Exp Annote
e [FieldUpdate Annote]
fups -> do
                  (ctor, sig) <- case [Maybe FQName] -> Maybe FQName
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe FQName] -> Maybe FQName) -> [Maybe FQName] -> Maybe FQName
forall a b. (a -> b) -> a -> b
$ (FieldUpdate Annote -> Maybe FQName)
-> [FieldUpdate Annote] -> [Maybe FQName]
forall a b. (a -> b) -> [a] -> [b]
map FieldUpdate Annote -> Maybe FQName
fupToField [FieldUpdate Annote]
fups of
                        Maybe FQName
Nothing -> Annote -> Text -> m (FQName, [(Maybe FQName, Type ())])
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"You cannot use `..' in a record update"
                        Just FQName
f  -> m (FQName, [(Maybe FQName, Type ())])
-> ((FQName, [(Maybe FQName, Type ())])
    -> m (FQName, [(Maybe FQName, Type ())]))
-> Maybe (FQName, [(Maybe FQName, Type ())])
-> m (FQName, [(Maybe FQName, Type ())])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Annote -> Text -> m (FQName, [(Maybe FQName, Type ())])
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Field update for nonexistent field") (FQName, [(Maybe FQName, Type ())])
-> m (FQName, [(Maybe FQName, Type ())])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                                 (Maybe (FQName, [(Maybe FQName, Type ())])
 -> m (FQName, [(Maybe FQName, Type ())]))
-> Maybe (FQName, [(Maybe FQName, Type ())])
-> m (FQName, [(Maybe FQName, Type ())])
forall a b. (a -> b) -> a -> b
$ Renamer -> FQName -> Maybe (FQName, [(Maybe FQName, Type ())])
forall a.
QNamish a =>
Renamer -> a -> Maybe (FQName, [(Maybe FQName, Type ())])
findCtorSigFromField Renamer
rn (Namespace -> Renamer -> FQName -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn FQName
f :: FQName)
                  let flds = ((Maybe FQName, Type ()) -> Maybe FQName)
-> [(Maybe FQName, Type ())] -> [FQName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe FQName, Type ()) -> Maybe FQName
forall a b. (a, b) -> a
fst [(Maybe FQName, Type ())]
sig
                  pats <- mapM (toRUpPat l fups) flds
                  exps <- mapM (toRUpExp l fups) $ zip pats flds
                  pure $ Case l e
                        [ Alt l
                              (PApp l (qnamish ctor) pats)
                              (UnGuardedRhs l (foldl' (App l) (Con l $ qnamish ctor) exps))
                              Nothing
                        ]
            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 fieldDecl :: MonadState Fresh m => FieldInfo -> m (Decl Annote, Decl Annote)
            fieldDecl :: forall (m :: * -> *).
MonadState Int m =>
FieldInfo -> m (Decl Annote, Decl Annote)
fieldDecl (Name Annote
ctor, (Name Annote
f, Type Annote
t, Int
i, Int
arr)) = do
                  let an :: Text -> Annote
an Text
s = Text -> Annote
MsgAnnote (Text -> Annote) -> Text -> Annote
forall a b. (a -> b) -> a -> b
$ Text
"Generated record field accessor for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Name Annote -> String
forall a. Pretty a => a -> String
prettyPrint Name Annote
f) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" at: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s
                  x  <- Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int m, Monad m) =>
Annote -> m (Name Annote)
fresh (Annote -> m (Name Annote)) -> Annote -> m (Name Annote)
forall a b. (a -> b) -> a -> b
$ Text -> Annote
an Text
"x"
                  x' <- fresh $ an "x'"
                  pure   ( TypeSig (an "TypeSig") [an "TypeSig Name" <$ f] (an "TypeSig Type" <$ t)
                         , PatBind (an "PatBind") (PVar (an "PVar") (an "PVar" <$ f))
                               ( UnGuardedRhs (an "UnGuardedRhs")
                                     ( Lambda (an "Lambda") [PVar (an "PVar") x]
                                           ( Case (an "Case") (Var (an "Var") (UnQual (an "Var") x))
                                                 [ Alt (an "Alt") (PApp (an "PApp") (UnQual (an "PApp") ctor) (argPats x' i arr))
                                                       (UnGuardedRhs (an "UnGuardedRhs") (Var (an "Var") (UnQual (an "Var") x')))
                                                       Nothing
                                                 ]
                                           )
                                     )
                               ) Nothing
                        )

            tupList :: (a, a) -> [a]
            tupList :: forall a. (a, a) -> [a]
tupList (a
x, a
y) = [a
x, a
y]

            flatten :: FieldDecl Annote -> [FieldDecl Annote]
            flatten :: FieldDecl Annote -> [FieldDecl Annote]
flatten (FieldDecl Annote
l [Name Annote]
xs Type Annote
t) = (Name Annote -> FieldDecl Annote)
-> [Name Annote] -> [FieldDecl Annote]
forall a b. (a -> b) -> [a] -> [b]
map (\ Name Annote
x -> Annote -> [Name Annote] -> Type Annote -> FieldDecl Annote
forall l. l -> [Name l] -> Type l -> FieldDecl l
FieldDecl Annote
l [Name Annote
x] Type Annote
t) [Name Annote]
xs

            -- TODO(chathhorn): remove this fieldinfo thing.
            fieldInfo :: (Name (), [(Name (), Type ())]) -> [FieldInfo]
            fieldInfo :: (Name (), [(Name (), Type ())]) -> [FieldInfo]
fieldInfo (Name ()
ctor, [(Name (), Type ())]
fs) = (Int -> (Name (), Type ()) -> FieldInfo)
-> [Int] -> [(Name (), Type ())] -> [FieldInfo]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((Int, (Name (), Type ())) -> FieldInfo)
-> Int -> (Name (), Type ()) -> FieldInfo
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((Int, (Name (), Type ())) -> FieldInfo)
 -> Int -> (Name (), Type ()) -> FieldInfo)
-> ((Int, (Name (), Type ())) -> FieldInfo)
-> Int
-> (Name (), Type ())
-> FieldInfo
forall a b. (a -> b) -> a -> b
$ Name () -> Int -> (Int, (Name (), Type ())) -> FieldInfo
fieldInfo' Name ()
ctor (Int -> (Int, (Name (), Type ())) -> FieldInfo)
-> Int -> (Int, (Name (), Type ())) -> FieldInfo
forall a b. (a -> b) -> a -> b
$ [(Name (), Type ())] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name (), Type ())]
fs) [Int
0..] [(Name (), Type ())]
fs

            fieldInfo' :: Name () -> Int -> (Int, (Name (), Type ())) -> FieldInfo
            fieldInfo' :: Name () -> Int -> (Int, (Name (), Type ())) -> FieldInfo
fieldInfo' Name ()
ctor Int
arr (Int
i, (Name ()
f, Type ()
t)) = (Annote
noAnn Annote -> Name () -> Name Annote
forall a b. a -> Name b -> Name a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name ()
ctor, (Annote
noAnn Annote -> Name () -> Name Annote
forall a b. a -> Name b -> Name a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name ()
f, Annote
noAnn Annote -> Type () -> Type Annote
forall a b. a -> Type b -> Type a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Type ()
t, Int
i, Int
arr))

            filterRecords :: CtorSigs -> Map (Name ()) [(Name (), Type ())]
            filterRecords :: CtorSigs -> Map (Name ()) [(Name (), Type ())]
filterRecords = ([(Maybe (Name ()), Type ())] -> Maybe [(Name (), Type ())])
-> CtorSigs -> Map (Name ()) [(Name (), Type ())]
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (([(Maybe (Name ()), Type ())] -> Maybe [(Name (), Type ())])
 -> CtorSigs -> Map (Name ()) [(Name (), Type ())])
-> ([(Maybe (Name ()), Type ())] -> Maybe [(Name (), Type ())])
-> CtorSigs
-> Map (Name ()) [(Name (), Type ())]
forall a b. (a -> b) -> a -> b
$ \ [(Maybe (Name ()), Type ())]
a -> if [(Maybe (Name ()), Type ())] -> Bool
forall a t. [(Maybe a, t)] -> Bool
isRecordSig [(Maybe (Name ()), Type ())]
a then [(Name (), Type ())] -> Maybe [(Name (), Type ())]
forall a. a -> Maybe a
Just ([(Name (), Type ())] -> Maybe [(Name (), Type ())])
-> [(Name (), Type ())] -> Maybe [(Name (), Type ())]
forall a b. (a -> b) -> a -> b
$ [(Maybe (Name ()), Type ())] -> [(Name (), Type ())]
forall a t. [(Maybe a, t)] -> [(a, t)]
toRecordSig [(Maybe (Name ()), Type ())]
a else Maybe [(Name (), Type ())]
forall a. Maybe a
Nothing

            isRecordSig :: [(Maybe a, t)] -> Bool
            isRecordSig :: forall a t. [(Maybe a, t)] -> Bool
isRecordSig [] = Bool
False
            isRecordSig [(Maybe a, t)]
s = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((Maybe a, t) -> Bool) -> [(Maybe a, t)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe a -> Bool)
-> ((Maybe a, t) -> Maybe a) -> (Maybe a, t) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a, t) -> Maybe a
forall a b. (a, b) -> a
fst) [(Maybe a, t)]
s

            toRecordSig :: [(Maybe a, t)] -> [(a, t)]
            toRecordSig :: forall a t. [(Maybe a, t)] -> [(a, t)]
toRecordSig = ((Maybe a, t) -> [(a, t)]) -> [(Maybe a, t)] -> [(a, t)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\ (Maybe a
n, t
t) -> [(a, t)] -> (a -> [(a, t)]) -> Maybe a -> [(a, t)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((a, t) -> [(a, t)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a, t) -> [(a, t)]) -> (a -> (a, t)) -> a -> [(a, t)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, t
t)) Maybe a
n)

            argPats :: Name Annote -> Int -> Int -> [Pat Annote]
            argPats :: Name Annote -> Int -> Int -> [Pat Annote]
argPats Name Annote
x Int
i Int
tot = let a :: Annote
a = Name Annote -> Annote
forall l. Name l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Name Annote
x in
                  Int -> Pat Annote -> [Pat Annote]
forall a. Int -> a -> [a]
replicate Int
i (Annote -> Pat Annote
forall l. l -> Pat l
PWildCard Annote
a) [Pat Annote] -> [Pat Annote] -> [Pat Annote]
forall a. Semigroup a => a -> a -> a
<> [Annote -> Name Annote -> Pat Annote
forall l. l -> Name l -> Pat l
PVar Annote
a Name Annote
x] [Pat Annote] -> [Pat Annote] -> [Pat Annote]
forall a. Semigroup a => a -> a -> a
<> Int -> Pat Annote -> [Pat Annote]
forall a. Int -> a -> [a]
replicate (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Annote -> Pat Annote
forall l. l -> Pat l
PWildCard Annote
a)

            inSig :: [FQName] -> (a -> Maybe FQName) -> a -> Bool
            inSig :: forall a. [FQName] -> (a -> Maybe FQName) -> a -> Bool
inSig [FQName]
sig a -> Maybe FQName
proj = Bool -> (FQName -> Bool) -> Maybe FQName -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (((FQName -> Bool) -> [FQName] -> Bool)
-> [FQName] -> (FQName -> Bool) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FQName -> Bool) -> [FQName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [FQName]
sig ((FQName -> Bool) -> Bool)
-> (FQName -> FQName -> Bool) -> FQName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FQName -> FQName -> Bool
forall a. Eq a => a -> a -> Bool
(==)) (Maybe FQName -> Bool) -> (a -> Maybe FQName) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe FQName
proj

            pfToField :: PatField Annote -> Maybe FQName
            pfToField :: PatField Annote -> Maybe FQName
pfToField = \ case
                  PFieldPat Annote
_ QName Annote
f' Pat Annote
_ -> FQName -> Maybe FQName
forall a. a -> Maybe a
Just (FQName -> Maybe FQName) -> FQName -> Maybe FQName
forall a b. (a -> b) -> a -> b
$ Namespace -> Renamer -> QName Annote -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
f'
                  PFieldPun Annote
_ QName Annote
f'   -> FQName -> Maybe FQName
forall a. a -> Maybe a
Just (FQName -> Maybe FQName) -> FQName -> Maybe FQName
forall a b. (a -> b) -> a -> b
$ Namespace -> Renamer -> QName Annote -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
f'
                  PatField Annote
_                -> Maybe FQName
forall a. Maybe a
Nothing

            pfToPat :: FQName -> PatField Annote -> Pat Annote
            pfToPat :: FQName -> PatField Annote -> Pat Annote
pfToPat FQName
f = \ case
                  PFieldPat Annote
_ QName Annote
_ Pat Annote
p  -> Pat Annote
p
                  PFieldPun Annote
l QName Annote
_    -> Annote -> Name Annote -> Pat Annote
forall l. l -> Name l -> Pat l
PVar Annote
l (Name Annote -> Pat Annote) -> Name Annote -> Pat Annote
forall a b. (a -> b) -> a -> b
$ Annote
l Annote -> Name () -> Name Annote
forall a b. a -> Name b -> Name a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FQName -> Name ()
name FQName
f
                  PFieldWildcard Annote
l -> Annote -> Name Annote -> Pat Annote
forall l. l -> Name l -> Pat l
PVar Annote
l (Name Annote -> Pat Annote) -> Name Annote -> Pat Annote
forall a b. (a -> b) -> a -> b
$ Annote
l Annote -> Name () -> Name Annote
forall a b. a -> Name b -> Name a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FQName -> Name ()
name FQName
f

            fupToField :: FieldUpdate Annote -> Maybe FQName
            fupToField :: FieldUpdate Annote -> Maybe FQName
fupToField = \ case
                  FieldUpdate Annote
_ QName Annote
f' Exp Annote
_ -> FQName -> Maybe FQName
forall a. a -> Maybe a
Just (FQName -> Maybe FQName) -> FQName -> Maybe FQName
forall a b. (a -> b) -> a -> b
$ Namespace -> Renamer -> QName Annote -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
f'
                  FieldPun Annote
_ QName Annote
f'      -> FQName -> Maybe FQName
forall a. a -> Maybe a
Just (FQName -> Maybe FQName) -> FQName -> Maybe FQName
forall a b. (a -> b) -> a -> b
$ Namespace -> Renamer -> QName Annote -> FQName
forall a b.
(QNamish a, QNamish b) =>
Namespace -> Renamer -> a -> b
rename Namespace
Value Renamer
rn QName Annote
f'
                  FieldUpdate Annote
_                  -> Maybe FQName
forall a. Maybe a
Nothing

            fupToExp :: FQName -> FieldUpdate Annote -> Exp Annote
            fupToExp :: FQName -> FieldUpdate Annote -> Exp Annote
fupToExp FQName
f = \ case
                  FieldUpdate Annote
_ QName Annote
_ Exp Annote
e  -> Exp Annote
e
                  FieldPun Annote
l QName Annote
_       -> Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l (QName Annote -> Exp Annote) -> QName Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote
l Annote -> Name () -> Name Annote
forall a b. a -> Name b -> Name a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FQName -> Name ()
name FQName
f
                  FieldWildcard Annote
l    -> Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l (QName Annote -> Exp Annote) -> QName Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote
l Annote -> Name () -> Name Annote
forall a b. a -> Name b -> Name a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FQName -> Name ()
name FQName
f

            convField :: FQName -> b -> (a -> Maybe FQName) -> (a -> b) -> [a] -> b
            convField :: forall b a.
FQName -> b -> (a -> Maybe FQName) -> (a -> b) -> [a] -> b
convField FQName
f b
d a -> Maybe FQName
proj a -> b
conv (a
a:[a]
as) = case a -> Maybe FQName
proj a
a of
                  Just FQName
x | FQName
x FQName -> FQName -> Bool
forall a. Eq a => a -> a -> Bool
== FQName
f        -> a -> b
conv a
a
                  Just FQName
_                 -> FQName -> b -> (a -> Maybe FQName) -> (a -> b) -> [a] -> b
forall b a.
FQName -> b -> (a -> Maybe FQName) -> (a -> b) -> [a] -> b
convField FQName
f b
d a -> Maybe FQName
proj a -> b
conv [a]
as
                  Maybe FQName
Nothing {- wildcard -} -> FQName -> b -> (a -> Maybe FQName) -> (a -> b) -> [a] -> b
forall b a.
FQName -> b -> (a -> Maybe FQName) -> (a -> b) -> [a] -> b
convField FQName
f (a -> b
conv a
a) a -> Maybe FQName
proj a -> b
conv [a]
as
            convField FQName
_ b
d a -> Maybe FQName
_ a -> b
_ []           = b
d

            toPat :: Annote -> [PatField Annote] -> FQName -> Pat Annote
            toPat :: Annote -> [PatField Annote] -> FQName -> Pat Annote
toPat Annote
l [PatField Annote]
fpats FQName
f = FQName
-> Pat Annote
-> (PatField Annote -> Maybe FQName)
-> (PatField Annote -> Pat Annote)
-> [PatField Annote]
-> Pat Annote
forall b a.
FQName -> b -> (a -> Maybe FQName) -> (a -> b) -> [a] -> b
convField FQName
f (Annote -> Pat Annote
forall l. l -> Pat l
PWildCard Annote
l) PatField Annote -> Maybe FQName
pfToField (FQName -> PatField Annote -> Pat Annote
pfToPat FQName
f) [PatField Annote]
fpats

            toExp :: Annote -> [FieldUpdate Annote] -> FQName -> Exp Annote
            toExp :: Annote -> [FieldUpdate Annote] -> FQName -> Exp Annote
toExp Annote
l [FieldUpdate Annote]
fups FQName
f = FQName
-> Exp Annote
-> (FieldUpdate Annote -> Maybe FQName)
-> (FieldUpdate Annote -> Exp Annote)
-> [FieldUpdate Annote]
-> Exp Annote
forall b a.
FQName -> b -> (a -> Maybe FQName) -> (a -> b) -> [a] -> b
convField FQName
f (Annote -> String -> Exp Annote
err Annote
l String
"uninitialized record field") FieldUpdate Annote -> Maybe FQName
fupToField (FQName -> FieldUpdate Annote -> Exp Annote
fupToExp FQName
f) [FieldUpdate Annote]
fups

            toRUpPat :: MonadState Fresh m => Annote -> [FieldUpdate Annote] -> FQName -> m (Pat Annote)
            toRUpPat :: forall (m :: * -> *).
MonadState Int m =>
Annote -> [FieldUpdate Annote] -> FQName -> m (Pat Annote)
toRUpPat Annote
l [FieldUpdate Annote]
fups FQName
f = do
                  x <- Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l
                  pure $ convField f (PVar l x) fupToField (PWildCard . ann) fups

            toRUpExp :: MonadError AstError m => Annote -> [FieldUpdate Annote] -> (Pat Annote, FQName) -> m (Exp Annote)
            toRUpExp :: forall (m :: * -> *).
MonadError AstError m =>
Annote
-> [FieldUpdate Annote] -> (Pat Annote, FQName) -> m (Exp Annote)
toRUpExp Annote
l [FieldUpdate Annote]
_    (PVar Annote
_ Name Annote
x, FQName
_) = 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 -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l (QName Annote -> Exp Annote) -> QName Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Name Annote -> QName Annote
forall a b. (QNamish a, QNamish b) => a -> b
qnamish Name Annote
x
            toRUpExp Annote
l [FieldUpdate Annote]
fups (Pat Annote
_, FQName
f)        = FQName
-> m (Exp Annote)
-> (FieldUpdate Annote -> Maybe FQName)
-> (FieldUpdate Annote -> m (Exp Annote))
-> [FieldUpdate Annote]
-> m (Exp Annote)
forall b a.
FQName -> b -> (a -> Maybe FQName) -> (a -> b) -> [a] -> b
convField FQName
f (Annote -> Text -> m (Exp Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Something went wrong while desugaring a record update")
                                                FieldUpdate Annote -> Maybe FQName
fupToField (Exp Annote -> m (Exp Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp Annote -> m (Exp Annote))
-> (FieldUpdate Annote -> Exp Annote)
-> FieldUpdate Annote
-> m (Exp Annote)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FQName -> FieldUpdate Annote -> Exp Annote
fupToExp FQName
f) [FieldUpdate Annote]
fups

-- | Turns Specials into normal identifiers.
normIds :: Monad m => Desugar m
normIds :: forall (m :: * -> *). Monad m => Desugar m
normIds = Desugar m
forall a. Monoid a => a
mempty { dsQName = T $ \ case
      Special Annote
l (UnitCon Annote
_)      -> Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l String
"()"
      Special Annote
l (ListCon Annote
_)      -> Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l String
"[_]"
      Special Annote
l (FunCon Annote
_)       -> Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l String
"->"
      -- I think this is only for the prefix constructor.
      Special Annote
l (TupleCon Annote
_ Boxed
_ Int
i) -> Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Int -> Name Annote
mkTuple Annote
l Int
i
      Special Annote
l (Cons Annote
_)         -> Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l String
"(:)"
      QName Annote
e                          -> QName Annote
e }

mkTuple :: Annote -> Int -> Name Annote
mkTuple :: Annote -> Int -> Name Annote
mkTuple Annote
l Int
n = Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l (String -> Name Annote) -> String -> Name Annote
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
',' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

-- | Removes parens in types, expressions, and patterns so they don't confuddle
--   everything.
deparenify :: Monad m => Desugar m
deparenify :: forall (m :: * -> *). Monad m => Desugar m
deparenify = Desugar m
forall a. Monoid a => a
mempty
      { dsExp = T $ \ case
            Paren   Annote
_ Exp Annote
n -> Exp Annote
n
            Exp Annote
e           -> Exp Annote
e
      , dsPat = T $ \ case
            PParen  Annote
_ Pat Annote
n -> Pat Annote
n
            Pat Annote
e           -> Pat Annote
e
      , dsType = T $ \ case
            TyParen Annote
_ Type Annote
n -> Type Annote
n
            Type Annote
e           -> Type Annote
e
      , dsDeclHead = T $ \ case
            DHParen Annote
_ DeclHead Annote
n -> DeclHead Annote
n
            DeclHead Annote
e           -> DeclHead Annote
e
      }

-- BEFORE: desugarFuns
-- | Turns sections and infix ops into regular applications and lambdas.
desugarInfix :: MonadState Fresh m => Desugar m
desugarInfix :: forall (m :: * -> *). MonadState Int m => Desugar m
desugarInfix = Desugar m
forall a. Monoid a => a
mempty
      { dsExp = TM $ \ case
            LeftSection Annote
l Exp Annote
e (QVarOp Annote
l' QName Annote
op)  -> 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 -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l' QName Annote
op) Exp Annote
e
            LeftSection Annote
l Exp Annote
e (QConOp Annote
l' QName Annote
op)  -> 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 -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Con Annote
l' QName Annote
op) Exp Annote
e
            RightSection Annote
l (QVarOp Annote
l' QName Annote
op) Exp Annote
e -> do
                  x <- Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l
                  pure $ Lambda l [PVar l x] $ App l (App l (Var l' op) $ Var l $ UnQual l x) e
            RightSection Annote
l (QConOp Annote
l' QName Annote
op) Exp Annote
e -> do
                  x <- Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l
                  pure $ Lambda l [PVar l x] $ App l (App l (Con l' op) $ Var l $ UnQual l x) e
            InfixApp Annote
l Exp Annote
e1 (QVarOp Annote
l' QName Annote
op) Exp Annote
e2 -> 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 -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l' QName Annote
op) Exp Annote
e1) Exp Annote
e2
            InfixApp Annote
l Exp Annote
e1 (QConOp Annote
l' QName Annote
op) Exp Annote
e2 -> 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 -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Con Annote
l' QName Annote
op) Exp Annote
e1) Exp Annote
e2
            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
      , dsConDecl = T $ \ case
            InfixConDecl Annote
l Type Annote
a Name Annote
n Type Annote
b -> Annote -> Name Annote -> [Type Annote] -> ConDecl Annote
forall l. l -> Name l -> [Type l] -> ConDecl l
ConDecl Annote
l Name Annote
n [Type Annote
a, Type Annote
b]
            ConDecl Annote
e                    -> ConDecl Annote
e
      , dsMatch = T $ \ case
            InfixMatch Annote
l Pat Annote
p1 Name Annote
n [Pat Annote]
p2 Rhs Annote
rhs Maybe (Binds Annote)
bs -> Annote
-> Name Annote
-> [Pat Annote]
-> Rhs Annote
-> Maybe (Binds Annote)
-> Match Annote
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match Annote
l Name Annote
n (Pat Annote
p1Pat Annote -> [Pat Annote] -> [Pat Annote]
forall a. a -> [a] -> [a]
:[Pat Annote]
p2) Rhs Annote
rhs Maybe (Binds Annote)
bs
            Match Annote
e                           -> Match Annote
e
      , dsDeclHead = T $ \ case
            DHInfix Annote
l TyVarBind Annote
bind Name Annote
n -> Annote -> DeclHead Annote -> TyVarBind Annote -> DeclHead Annote
forall l. l -> DeclHead l -> TyVarBind l -> DeclHead l
DHApp Annote
l (Annote -> Name Annote -> DeclHead Annote
forall l. l -> Name l -> DeclHead l
DHead Annote
l Name Annote
n) TyVarBind Annote
bind
            DeclHead Annote
e                -> DeclHead Annote
e
      }

-- | TODO Apparently this should actually desugar to guards:
--
-- > f (-k) = v
--
-- is actually sugar for
--
-- > f z | z == negate (fromInteger k) = v
desugarNegLitPats :: Monad m => Desugar m
desugarNegLitPats :: forall (m :: * -> *). Monad m => Desugar m
desugarNegLitPats = Desugar m
forall a. Monoid a => a
mempty {dsPat = T $ \ case
      PLit Annote
l (Negative Annote
l') Literal Annote
lit -> Annote -> Sign Annote -> Literal Annote -> Pat Annote
forall l. l -> Sign l -> Literal l -> Pat l
PLit Annote
l (Annote -> Sign Annote
forall l. l -> Sign l
Signless Annote
l') (Literal Annote -> Pat Annote) -> Literal Annote -> Pat Annote
forall a b. (a -> b) -> a -> b
$ Literal Annote -> Literal Annote
neg Literal Annote
lit
      Pat Annote
p                        -> Pat Annote
p}

neg :: Literal Annote -> Literal Annote
neg :: Literal Annote -> Literal Annote
neg = \ case
      Int        Annote
l Integer
n String
s -> Annote -> Integer -> String -> Literal Annote
forall l. l -> Integer -> String -> Literal l
Int        Annote
l (-Integer
n) String
s
      Frac       Annote
l Rational
n String
s -> Annote -> Rational -> String -> Literal Annote
forall l. l -> Rational -> String -> Literal l
Frac       Annote
l (-Rational
n) String
s
      PrimInt    Annote
l Integer
n String
s -> Annote -> Integer -> String -> Literal Annote
forall l. l -> Integer -> String -> Literal l
PrimInt    Annote
l (-Integer
n) String
s
      PrimWord   Annote
l Integer
n String
s -> Annote -> Integer -> String -> Literal Annote
forall l. l -> Integer -> String -> Literal l
PrimWord   Annote
l (-Integer
n) String
s
      PrimFloat  Annote
l Rational
n String
s -> Annote -> Rational -> String -> Literal Annote
forall l. l -> Rational -> String -> Literal l
PrimFloat  Annote
l (-Rational
n) String
s
      PrimDouble Annote
l Rational
n String
s -> Annote -> Rational -> String -> Literal Annote
forall l. l -> Rational -> String -> Literal l
PrimDouble Annote
l (-Rational
n) String
s
      Literal Annote
n                -> Literal Annote
n

-- AFTER: desugarFuns
-- | Turns tuples into applications of a tuple constructor (also in types and pats):
--
-- > (x, y, z)
--
-- becomes
--
-- > ((,,) x y z)
desugarTuples :: Monad m => Desugar m
desugarTuples :: forall (m :: * -> *). Monad m => Desugar m
desugarTuples = Desugar m
forall a. Monoid a => a
mempty
      { dsExp = T $ \ case
            Tuple Annote
l Boxed
_ [Exp Annote]
es   -> (Exp Annote -> Exp Annote -> Exp Annote)
-> Exp Annote -> [Exp Annote] -> Exp Annote
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App 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 -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Int -> Name Annote
mkTuple Annote
l (Int -> Name Annote) -> Int -> Name Annote
forall a b. (a -> b) -> a -> b
$ [Exp Annote] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp Annote]
es) [Exp Annote]
es
            Exp Annote
e              -> Exp Annote
e
      , dsType = T $ \ case
            TyTuple Annote
l Boxed
_ [Type Annote]
ts -> (Type Annote -> Type Annote -> Type Annote)
-> Type Annote -> [Type Annote] -> Type Annote
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Annote -> Type Annote -> Type Annote -> Type Annote
forall l. l -> Type l -> Type l -> Type l
TyApp Annote
l) (Annote -> QName Annote -> Type Annote
forall l. l -> QName l -> Type l
TyCon Annote
l (QName Annote -> Type Annote) -> QName Annote -> Type Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Int -> Name Annote
mkTuple Annote
l (Int -> Name Annote) -> Int -> Name Annote
forall a b. (a -> b) -> a -> b
$ [Type Annote] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type Annote]
ts) [Type Annote]
ts
            Type Annote
t              -> Type Annote
t
      , dsPat = T $ \ case
            PTuple Annote
l Boxed
_ [Pat Annote]
ps  -> Annote -> QName Annote -> [Pat Annote] -> Pat Annote
forall l. l -> QName l -> [Pat l] -> Pat l
PApp Annote
l (Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Int -> Name Annote
mkTuple Annote
l (Int -> Name Annote) -> Int -> Name Annote
forall a b. (a -> b) -> a -> b
$ [Pat Annote] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat Annote]
ps) [Pat Annote]
ps
            Pat Annote
p              -> Pat Annote
p
      }

-- BEFORE: desugarTyFuns
-- AFTER: desugarInfix
-- | Turns piece-wise function definitions into a single PatBind with a lambda
--   and case expression on the RHS. E.g.:
--
-- > f p1 p2 = rhs1
-- > f q1 q2 = rhs2
--
-- becomes
--
-- > f = \ $1 $2 -> case ($1, $2) of { (p1, p2) -> rhs1; (q1, q2) -> rhs2 }
desugarFuns :: (MonadState Fresh m, MonadError AstError m) => Desugar m
desugarFuns :: forall (m :: * -> *).
(MonadState Int 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 Decl Annote -> m (Decl Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Decl Annote -> m (Decl Annote)
desugarFun [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 Decl Annote -> m (Decl Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Decl Annote -> m (Decl Annote)
desugarFun [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) => Decl Annote -> m (Decl Annote)
            desugarFun :: forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Decl Annote -> m (Decl Annote)
desugarFun = \ case
                  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 Match Annote -> m (Alt Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Match Annote -> m (Alt Annote)
toAlt [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 Int m, MonadError AstError m) =>
Annote -> [Alt Annote] -> Int -> m (Exp Annote)
buildLambda Annote
l [Alt Annote]
alts = \ case
                  Int
1     -> do
                        x <- Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int 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
                  Int
arity -> do
                        xs <- Int -> m (Name Annote) -> m [Name Annote]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
arity (Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int 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) => Match Annote -> m (Alt Annote)
            toAlt :: forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Match Annote -> m (Alt Annote)
toAlt = \ 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' 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]
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
"unsupported declaration syntax."

-- | Turns
--
-- > case e of {...}
--
-- into
--
-- > (\ x -> case x of {...}) e
liftDiscriminator :: MonadState Fresh m => Desugar m
liftDiscriminator :: forall (m :: * -> *). MonadState Int m => Desugar m
liftDiscriminator = Desugar m
forall a. Monoid a => a
mempty {dsExp = TM $ \ case
      Case Annote
l Exp Annote
e [Alt Annote]
alts -> do
            x <- Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l
            pure $ App l (Lambda l [PVar l x] $ Case l (Var l $ UnQual l x) alts) e
      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}

-- | Turn cases with multiple alts into cases with two alts: an alt with a
--   pattern and another with a default, wildcard branch.
--
-- > case x of
-- >   p1 -> e1
-- >   p2 -> e2
-- >   p3 -> e3
--
-- becomes
--
-- > case x of
-- >   p1 -> e1
-- >   _  -> case x of
-- >           p2 -> e2
-- >            _ -> case x of
-- >                   p3 -> e3
-- >                    _ -> undefined
flattenAlts :: Monad m => Desugar m
flattenAlts :: forall (m :: * -> *). Monad m => Desugar m
flattenAlts = Desugar m
forall a. Monoid a => a
mempty {dsExp = T $ \ case
      Case Annote
l Exp Annote
e [Alt Annote]
alts -> Annote -> Exp Annote -> [Alt Annote] -> Exp Annote
forall l. l -> Exp l -> [Alt l] -> Exp l
Case Annote
l Exp Annote
e ([Alt Annote] -> Exp Annote) -> [Alt Annote] -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Exp Annote -> [Alt Annote] -> [Alt Annote]
flatten Annote
l Exp Annote
e [Alt Annote]
alts
      Exp Annote
e             -> Exp Annote
e}
      where flatten :: Annote -> Exp Annote -> [Alt Annote] -> [Alt Annote]
            flatten :: Annote -> Exp Annote -> [Alt Annote] -> [Alt Annote]
flatten Annote
l Exp Annote
e = \ case
                  [a :: Alt Annote
a@Alt {}]                           -> [ Alt Annote
a ]
                  as :: [Alt Annote]
as@[Alt {}, Alt Annote
_ (PWildCard Annote
_) Rhs Annote
_ Maybe (Binds Annote)
_] -> [Alt Annote]
as
                  (Alt Annote
l' Pat Annote
p' Rhs Annote
rhs' Maybe (Binds Annote)
binds' : [Alt Annote]
as)         -> [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' Pat Annote
p' Rhs Annote
rhs' Maybe (Binds Annote)
binds', 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) (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 Exp Annote
e ([Alt Annote] -> Exp Annote) -> [Alt Annote] -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Exp Annote -> [Alt Annote] -> [Alt Annote]
flatten Annote
l Exp Annote
e [Alt Annote]
as) Maybe (Binds Annote)
forall a. Maybe a
Nothing]
                  [Alt Annote]
as                                   -> [Alt Annote]
as

-- | Should run after function desugarage. From the Haskell 98 report:
--
-- > case v of
-- >   p | g1 -> e1
-- >     | gn -> en where { decls }
-- >   _    -> e'
-- >
--
-- becomes
--
-- > case e' of
-- >   y -> case v of
-- >     p -> let { decls } in
-- >       if g1 then e1 else if gn then en else y
-- >     _ -> y
desugarGuards :: MonadState Fresh m => Desugar m
desugarGuards :: forall (m :: * -> *). MonadState Int m => Desugar m
desugarGuards = Desugar m
forall a. Monoid a => a
mempty { dsExp = TM $ \ case
            Case Annote
l1 Exp Annote
v [Alt Annote
l2 Pat Annote
p (GuardedRhss Annote
l3 [GuardedRhs Annote]
rhs) Maybe (Binds Annote)
binds, Alt Annote
l4 (PWildCard Annote
l5) (UnGuardedRhs Annote
l6 Exp Annote
e') Maybe (Binds Annote)
Nothing] -> do
                  y <- Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l1
                  pure $ Case l1 e'
                        [ Alt l2 (PVar l2 y)
                              ( UnGuardedRhs l3 $ Case l3 v
                                    [ Alt l3 p (UnGuardedRhs l3 $ toLet l3 (Var l6 $ UnQual l6 y) binds rhs) Nothing
                                    , Alt l4 (PWildCard l5) (UnGuardedRhs l6 $ Var l6 $ UnQual l6 y) Nothing
                                    ]
                              )
                              Nothing
                        ]
            Case Annote
l1 Exp Annote
v [Alt Annote
l2 Pat Annote
p (GuardedRhss Annote
l3 [GuardedRhs Annote]
rhs) Maybe (Binds Annote)
binds] ->
                  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
l1 Exp Annote
v [ Annote
-> Pat Annote -> Rhs Annote -> Maybe (Binds Annote) -> Alt Annote
forall l. l -> Pat l -> Rhs l -> Maybe (Binds l) -> Alt l
Alt Annote
l2 Pat Annote
p (Annote -> Exp Annote -> Rhs Annote
forall l. l -> Exp l -> Rhs l
UnGuardedRhs Annote
l3 (Exp Annote -> Rhs Annote) -> Exp Annote -> Rhs Annote
forall a b. (a -> b) -> a -> b
$ Annote
-> Exp Annote
-> Maybe (Binds Annote)
-> [GuardedRhs Annote]
-> Exp Annote
toLet Annote
l3 (Annote -> String -> Exp Annote
err Annote
l1 String
"pattern match failure") Maybe (Binds Annote)
binds [GuardedRhs Annote]
rhs) Maybe (Binds Annote)
forall a. Maybe a
Nothing ]
            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 toLet :: Annote -> Exp Annote -> Maybe (Binds Annote) -> [GuardedRhs Annote] -> Exp Annote
            toLet :: Annote
-> Exp Annote
-> Maybe (Binds Annote)
-> [GuardedRhs Annote]
-> Exp Annote
toLet Annote
l Exp Annote
y Maybe (Binds Annote)
binds [GuardedRhs Annote]
rhs = (Exp Annote -> Exp Annote)
-> (Binds Annote -> Exp Annote -> Exp Annote)
-> Maybe (Binds Annote)
-> Exp Annote
-> Exp Annote
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Exp Annote -> Exp Annote
forall a. a -> a
id (Annote -> Binds Annote -> Exp Annote -> Exp Annote
forall l. l -> Binds l -> Exp l -> Exp l
Let Annote
l) Maybe (Binds Annote)
binds (Exp Annote -> Exp Annote) -> Exp Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ (GuardedRhs Annote -> Exp Annote -> Exp Annote)
-> Exp Annote -> [GuardedRhs Annote] -> Exp Annote
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr GuardedRhs Annote -> Exp Annote -> Exp Annote
toIfs Exp Annote
y [GuardedRhs Annote]
rhs

            toIfs :: GuardedRhs Annote -> Exp Annote -> Exp Annote
            toIfs :: GuardedRhs Annote -> Exp Annote -> Exp Annote
toIfs = \ case
                  GuardedRhs Annote
l [Qualifier Annote
_ Exp Annote
g1] Exp Annote
e1 -> Annote -> Exp Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l -> Exp l
If Annote
l Exp Annote
g1 Exp Annote
e1
                  GuardedRhs Annote
_                                -> Exp Annote -> Exp Annote
forall a. a -> a
id

err :: Annote -> String -> Exp Annote
err :: Annote -> String -> Exp Annote
err Annote
l String
s = Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l (QName Annote -> Exp Annote) -> QName Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l String
"error") (Exp Annote -> Exp Annote) -> Exp Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Literal Annote -> Exp Annote
forall l. l -> Literal l -> Exp l
Lit Annote
l (Literal Annote -> Exp Annote) -> Literal Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> String -> Literal Annote
forall l. l -> String -> String -> Literal l
String Annote
l String
s String
""

-- | Turns where clauses into lets. Only valid after guard desugarage. E.g.:
--
-- > f x = a where a = b
--
-- becomes
--
-- > f x = let a = b in a
wheresToLets :: MonadError AstError m => Desugar m
wheresToLets :: forall (m :: * -> *). MonadError AstError m => Desugar m
wheresToLets = Desugar m
forall a. Monoid a => a
mempty
      { dsMatch = TM $ \ case
            Match Annote
l Name Annote
name [Pat Annote]
ps (UnGuardedRhs Annote
l' Exp Annote
e) (Just Binds Annote
binds) -> Match Annote -> m (Match Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match Annote -> m (Match Annote))
-> Match Annote -> m (Match Annote)
forall a b. (a -> b) -> a -> b
$ Annote
-> Name Annote
-> [Pat Annote]
-> Rhs Annote
-> Maybe (Binds Annote)
-> Match Annote
forall l.
l -> Name l -> [Pat l] -> Rhs l -> Maybe (Binds l) -> Match l
Match Annote
l Name Annote
name [Pat Annote]
ps (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 -> Binds Annote -> Exp Annote -> Exp Annote
forall l. l -> Binds l -> Exp l -> Exp l
Let Annote
l' Binds Annote
binds Exp Annote
e) Maybe (Binds Annote)
forall a. Maybe a
Nothing
            Match Annote
l Name Annote
_ [Pat Annote]
_ (GuardedRhss Annote
_ [GuardedRhs Annote]
_) Maybe (Binds Annote)
_                  -> Annote -> Text -> m (Match Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Annote
l :: Annote) Text
"Guards are not supported"
            Match Annote
m                                                -> Match Annote -> m (Match Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Match Annote
m
      , dsDecl = TM $ \ case
            PatBind Annote
l Pat Annote
p (UnGuardedRhs Annote
l' Exp Annote
e) (Just 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 -> Binds Annote -> Exp Annote -> Exp Annote
forall l. l -> Binds l -> Exp l -> Exp l
Let Annote
l' Binds Annote
binds Exp Annote
e) Maybe (Binds Annote)
forall a. Maybe a
Nothing
            PatBind Annote
l Pat Annote
_ (GuardedRhss Annote
_ [GuardedRhs Annote]
_) Maybe (Binds Annote)
_              -> Annote -> Text -> m (Decl Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Annote
l :: Annote) Text
"Guards are not supported"
            Decl Annote
p                                            -> Decl Annote -> m (Decl Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Decl Annote
p
      , dsAlt = TM $ \ case
            Alt Annote
l Pat Annote
p (UnGuardedRhs Annote
l' Exp Annote
e) (Just 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 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 -> Binds Annote -> Exp Annote -> Exp Annote
forall l. l -> Binds l -> Exp l -> Exp l
Let Annote
l' Binds Annote
binds Exp Annote
e) Maybe (Binds Annote)
forall a. Maybe a
Nothing
            a :: Alt Annote
a@(Alt Annote
l Pat Annote
_ (GuardedRhss Annote
_ [GuardedRhs Annote]
_) Maybe (Binds Annote)
_)          -> Annote -> Text -> m (Alt Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Annote
l :: Annote) (Text -> m (Alt Annote)) -> Text -> m (Alt Annote)
forall a b. (a -> b) -> a -> b
$ Text
"Guards are not supported: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Alt () -> String
forall a. Show a => a -> String
show (Alt () -> String) -> Alt () -> String
forall a b. (a -> b) -> a -> b
$ Alt Annote -> Alt ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Alt Annote
a)
            Alt Annote
a                                        -> Alt Annote -> m (Alt Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Alt Annote
a
      }

-- | Turns do-notation into a series of >>= \\ x ->. Turns LetStmts into Lets.
--   E.g.:
--
-- > do p1 <- m
-- >    let p2 = e
-- >    return e
--
-- becomes
--
-- > m >>= (\ p1 -> (let p2 = e in return e))
desugarDos :: (MonadState Fresh m, MonadError AstError m) => Desugar m
desugarDos :: forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Desugar m
desugarDos = Desugar m
forall a. Monoid a => a
mempty { dsExp = TM $ \ case
      Do Annote
l [Stmt Annote]
stmts -> Annote -> [Stmt Annote] -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Annote -> [Stmt Annote] -> m (Exp Annote)
transDo Annote
l [Stmt Annote]
stmts
      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 transDo :: (MonadState Fresh m, MonadError AstError m) => Annote -> [Stmt Annote] -> m (Exp Annote)
            transDo :: forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Annote -> [Stmt Annote] -> m (Exp Annote)
transDo Annote
l = \ case
                  Generator Annote
l' Pat Annote
p Exp Annote
e : [Stmt Annote]
stmts -> Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l' (Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l' (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l' (QName Annote -> Exp Annote) -> QName Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l' (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Symbol Annote
l' String
">>=") Exp Annote
e) (Exp Annote -> Exp Annote)
-> (Exp Annote -> Exp Annote) -> Exp Annote -> Exp Annote
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annote -> [Pat Annote] -> Exp Annote -> Exp Annote
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda Annote
l' [Pat Annote
p] (Exp Annote -> Exp Annote) -> m (Exp Annote) -> m (Exp Annote)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annote -> [Stmt Annote] -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Annote -> [Stmt Annote] -> m (Exp Annote)
transDo Annote
l [Stmt Annote]
stmts
                  [Qualifier Annote
_ 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
                  Qualifier Annote
l' Exp Annote
e : [Stmt Annote]
stmts   -> Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l' (Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l' (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l' (QName Annote -> Exp Annote) -> QName Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l' (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Symbol Annote
l' String
">>=") Exp Annote
e) (Exp Annote -> Exp Annote)
-> (Exp Annote -> Exp Annote) -> Exp Annote -> Exp Annote
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annote -> [Pat Annote] -> Exp Annote -> Exp Annote
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda Annote
l' [Annote -> Pat Annote
forall l. l -> Pat l
PWildCard Annote
l'] (Exp Annote -> Exp Annote) -> m (Exp Annote) -> m (Exp Annote)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annote -> [Stmt Annote] -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Annote -> [Stmt Annote] -> m (Exp Annote)
transDo Annote
l [Stmt Annote]
stmts
                  LetStmt Annote
l' Binds Annote
binds : [Stmt Annote]
stmts -> Annote -> Binds Annote -> Exp Annote -> Exp Annote
forall l. l -> Binds l -> Exp l -> Exp l
Let Annote
l' Binds Annote
binds (Exp Annote -> Exp Annote) -> m (Exp Annote) -> m (Exp Annote)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annote -> [Stmt Annote] -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Annote -> [Stmt Annote] -> m (Exp Annote)
transDo Annote
l [Stmt Annote]
stmts
                  Stmt Annote
s : [Stmt Annote]
_                    -> Annote -> Text -> m (Exp Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Stmt Annote -> Annote
forall l. Stmt l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Stmt Annote
s) Text
"unsupported syntax in do-block."
                  []                       -> Annote -> Text -> m (Exp Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt Annote
l Text
"Ill-formed do-block"

normTyContext :: Monad m => Desugar m
normTyContext :: forall (m :: * -> *). Monad m => Desugar m
normTyContext = Desugar m
forall a. Monoid a => a
mempty { dsType = T $ \ case
      TyForall Annote
l Maybe [TyVarBind Annote]
tvs Maybe (Context Annote)
Nothing Type Annote
t               -> Annote
-> Maybe [TyVarBind Annote]
-> Maybe (Context Annote)
-> Type Annote
-> Type Annote
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
TyForall Annote
l Maybe [TyVarBind Annote]
tvs (Context Annote -> Maybe (Context Annote)
forall a. a -> Maybe a
Just (Context Annote -> Maybe (Context Annote))
-> Context Annote -> Maybe (Context Annote)
forall a b. (a -> b) -> a -> b
$ Annote -> [Asst Annote] -> Context Annote
forall l. l -> [Asst l] -> Context l
CxTuple Annote
l []) Type Annote
t
      TyForall Annote
l Maybe [TyVarBind Annote]
tvs (Just (CxEmpty Annote
_)) Type Annote
t    -> Annote
-> Maybe [TyVarBind Annote]
-> Maybe (Context Annote)
-> Type Annote
-> Type Annote
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
TyForall Annote
l Maybe [TyVarBind Annote]
tvs (Context Annote -> Maybe (Context Annote)
forall a. a -> Maybe a
Just (Context Annote -> Maybe (Context Annote))
-> Context Annote -> Maybe (Context Annote)
forall a b. (a -> b) -> a -> b
$ Annote -> [Asst Annote] -> Context Annote
forall l. l -> [Asst l] -> Context l
CxTuple Annote
l []) Type Annote
t
      TyForall Annote
l Maybe [TyVarBind Annote]
tvs (Just (CxSingle Annote
_ Asst Annote
a)) Type Annote
t -> Annote
-> Maybe [TyVarBind Annote]
-> Maybe (Context Annote)
-> Type Annote
-> Type Annote
forall l.
l -> Maybe [TyVarBind l] -> Maybe (Context l) -> Type l -> Type l
TyForall Annote
l Maybe [TyVarBind Annote]
tvs (Context Annote -> Maybe (Context Annote)
forall a. a -> Maybe a
Just (Context Annote -> Maybe (Context Annote))
-> Context Annote -> Maybe (Context Annote)
forall a b. (a -> b) -> a -> b
$ Annote -> [Asst Annote] -> Context Annote
forall l. l -> [Asst l] -> Context l
CxTuple Annote
l [Asst Annote
a]) Type Annote
t
      Type Annote
t                                      -> Type Annote
t}

-- | Turns the type a -> b into (->) a b.
desugarTyFuns :: Monad m => Desugar m
desugarTyFuns :: forall (m :: * -> *). Monad m => Desugar m
desugarTyFuns = Desugar m
forall a. Monoid a => a
mempty { dsType = T $ \ case
      TyFun (Annote
l :: Annote) Type Annote
a Type Annote
b -> Annote -> Type Annote -> Type Annote -> Type Annote
forall l. l -> Type l -> Type l -> Type l
TyApp Annote
l (Annote -> Type Annote -> Type Annote -> Type Annote
forall l. l -> Type l -> Type l -> Type l
TyApp Annote
l (Annote -> QName Annote -> Type Annote
forall l. l -> QName l -> Type l
TyCon Annote
l (Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l String
"->"))) Type Annote
a) Type Annote
b
      Type Annote
t                       -> Type Annote
t}

-- TODO(chathhorn): recursive bindings?
-- | 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 Int 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 Decl Annote -> Exp Annote -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Decl Annote -> Exp Annote -> m (Exp Annote)
transLet 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) => Decl Annote -> Exp Annote -> m (Exp Annote)
            transLet :: forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Decl Annote -> Exp Annote -> m (Exp Annote)
transLet (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 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 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

-- | Turns ifs into cases.
--
-- > if e1 then e2 else e3
--
-- becomes
--
-- > case e1 of { True -> e2; False -> e3 }
desugarIfs :: Monad m => Desugar m
desugarIfs :: forall (m :: * -> *). Monad m => Desugar m
desugarIfs = Desugar m
forall a. Monoid a => a
mempty { dsExp = T $ \ case
      If Annote
l Exp Annote
e1 Exp Annote
e2 Exp Annote
e3 -> 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 (Annote -> QName Annote -> [Pat Annote] -> Pat Annote
forall l. l -> QName l -> [Pat l] -> Pat l
PApp Annote
l (Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l String
"True")  []) (Annote -> Exp Annote -> Rhs Annote
forall l. l -> Exp l -> Rhs l
UnGuardedRhs Annote
l Exp Annote
e2) Maybe (Binds Annote)
forall a. Maybe a
Nothing
            , 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 -> QName Annote -> [Pat Annote] -> Pat Annote
forall l. l -> QName l -> [Pat l] -> Pat l
PApp Annote
l (Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l String
"False") []) (Annote -> Exp Annote -> Rhs Annote
forall l. l -> Exp l -> Rhs l
UnGuardedRhs Annote
l Exp Annote
e3) Maybe (Binds Annote)
forall a. Maybe a
Nothing
            ]
      Exp Annote
e             -> Exp Annote
e}

desugarNegs :: Monad m => Desugar m
desugarNegs :: forall (m :: * -> *). Monad m => Desugar m
desugarNegs = Desugar m
forall a. Monoid a => a
mempty { dsExp = T $ \ case
      NegApp Annote
l Exp Annote
e -> Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l (QName Annote -> Exp Annote) -> QName Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l (Name Annote -> QName Annote) -> Name Annote -> QName Annote
forall a b. (a -> b) -> a -> b
$ Annote -> String -> Name Annote
forall l. l -> String -> Name l
Ident Annote
l String
"-") (Exp Annote -> Exp Annote) -> Exp Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Literal Annote -> Exp Annote
forall l. l -> Literal l -> Exp l
Lit Annote
l (Literal Annote -> Exp Annote) -> Literal Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Integer -> String -> Literal Annote
forall l. l -> Integer -> String -> Literal l
Int Annote
l Integer
0 String
"0") Exp Annote
e
      Exp Annote
e          -> Exp Annote
e}

-- | Turns Lambdas with several bindings into several lambdas with single
--   bindings. E.g.:
--
-- > \ p1 p2 -> e
--
-- becomes
--
-- > \ p1 -> \ p2 -> e
flattenLambdas :: Monad m => Desugar m
flattenLambdas :: forall (m :: * -> *). Monad m => Desugar m
flattenLambdas = Desugar m
forall a. Monoid a => a
mempty { dsExp = T $ \ case
      Lambda Annote
l [Pat Annote]
ps Exp Annote
e -> (Pat Annote -> Exp Annote -> Exp Annote)
-> Exp Annote -> [Pat Annote] -> Exp Annote
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Annote -> [Pat Annote] -> Exp Annote -> Exp Annote
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda Annote
l ([Pat Annote] -> Exp Annote -> Exp Annote)
-> (Pat Annote -> [Pat Annote])
-> Pat Annote
-> Exp Annote
-> Exp Annote
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat Annote -> [Pat Annote]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) Exp Annote
e [Pat Annote]
ps
      Exp Annote
e             -> Exp Annote
e}

-- | Replaces non-var patterns in lambdas with a fresh var and a case. E.g.:
--
-- > \ (a, b) -> e
--
-- becomes
--
-- > \ $x -> case $x of { (a, b) -> e }
depatLambdas :: MonadState Fresh m => Desugar m
depatLambdas :: forall (m :: * -> *). MonadState Int m => Desugar m
depatLambdas = Desugar m
forall a. Monoid a => a
mempty { dsExp = TM $ \ case
      n :: Exp Annote
n@(Lambda Annote
_ [PVar Annote
_ Name Annote
_] Exp Annote
_) -> Exp Annote -> m (Exp Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp Annote
n
      Lambda Annote
l [Pat Annote
p] Exp Annote
e            -> do
            x <- Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l
            pure $ Lambda l [PVar l x] (Case l (Var l $ UnQual l x) [Alt l p (UnGuardedRhs l e) Nothing])
      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}

-- | Desugars as-patterns in (and only in) cases into more cases. Should run
--   after depatLambdas. E.g.:
--
-- > case e1 of
-- >   x@(C y@p) -> e2
--
-- becomes
--
-- > case e1 of { C p -> (\ x -> ((\ y -> e2) p)) (C p) }
desugarAsPats :: (MonadState Fresh m, MonadError AstError m) => Desugar m
desugarAsPats :: forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Desugar m
desugarAsPats = Desugar m
forall a. Monoid a => a
mempty { dsAlt = TM $ \ case
      Alt Annote
l Pat Annote
p (UnGuardedRhs Annote
l' Exp Annote
e) Maybe (Binds Annote)
Nothing -> do
            p'  <- Pat Annote -> m (Pat Annote)
forall (m :: * -> *).
MonadState Int m =>
Pat Annote -> m (Pat Annote)
deWild Pat Annote
p
            app <- foldrM (mkApp l) e $ getAses p'
            pure $ Alt l (deAs p') (UnGuardedRhs l' app) Nothing
      Alt Annote
e                                   -> Alt Annote -> m (Alt Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Alt Annote
e}

      where mkApp :: (MonadState Fresh m, MonadError AstError m) => Annote -> (Pat Annote, Pat Annote) -> Exp Annote -> m (Exp Annote)
            mkApp :: forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Annote -> (Pat Annote, Pat Annote) -> Exp Annote -> m (Exp Annote)
mkApp Annote
l (Pat Annote
p, Pat Annote
p') Exp Annote
e = Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l (Annote -> [Pat Annote] -> Exp Annote -> Exp Annote
forall l. l -> [Pat l] -> Exp l -> Exp l
Lambda Annote
l [Pat Annote
p] Exp Annote
e) (Exp Annote -> Exp Annote) -> m (Exp Annote) -> m (Exp Annote)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat Annote -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Pat Annote -> m (Exp Annote)
patToExp Pat Annote
p'

            getAses :: Pat Annote -> [(Pat Annote, Pat Annote)]
            getAses :: Pat Annote -> [(Pat Annote, Pat Annote)]
getAses Pat Annote
p = [(Annote -> Name Annote -> Pat Annote
forall l. l -> Name l -> Pat l
PVar Annote
l Name Annote
n, Pat Annote
p) | PAsPat (Annote
l :: Annote) Name Annote
n Pat Annote
p <- Pat Annote -> [Pat Annote]
forall a b. (Data a, Data b) => a -> [b]
query Pat Annote
p]

            deAs :: Pat Annote -> Pat Annote
            deAs :: Pat Annote -> Pat Annote
deAs = (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
                  PAsPat (Annote
_ :: Annote) Name Annote
_ Pat Annote
p -> Pat Annote
p
                  Pat Annote
n                        -> Pat Annote
n

            deWild :: MonadState Fresh m => Pat Annote -> m (Pat Annote)
            deWild :: forall (m :: * -> *).
MonadState Int m =>
Pat Annote -> m (Pat Annote)
deWild = (Pat Annote -> m (Pat Annote)) -> Pat Annote -> m (Pat Annote)
forall (m :: * -> *) a b.
(Monad m, Data a, Data b) =>
(a -> m a) -> b -> m b
transformM ((Pat Annote -> m (Pat Annote)) -> Pat Annote -> m (Pat Annote))
-> (Pat Annote -> m (Pat Annote)) -> Pat Annote -> m (Pat Annote)
forall a b. (a -> b) -> a -> b
$ \ case
                  PWildCard Annote
l -> Annote -> Name Annote -> Pat Annote
forall l. l -> Name l -> Pat l
PVar Annote
l (Name Annote -> Pat Annote) -> m (Name Annote) -> m (Pat Annote)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annote -> m (Name Annote)
forall (m :: * -> *).
(MonadState Int m, Monad m) =>
Annote -> m (Name Annote)
fresh Annote
l
                  Pat Annote
p           -> Pat Annote -> m (Pat Annote)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat Annote
p

            patToExp :: (MonadState Fresh m, MonadError AstError m) => Pat Annote -> m (Exp Annote)
            patToExp :: forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Pat Annote -> m (Exp Annote)
patToExp = \ case
                  PVar Annote
l Name Annote
n                -> 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 -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Var Annote
l (QName Annote -> Exp Annote) -> QName Annote -> Exp Annote
forall a b. (a -> b) -> a -> b
$ Annote -> Name Annote -> QName Annote
forall l. l -> Name l -> QName l
UnQual Annote
l Name Annote
n
                  PLit Annote
l (Signless Annote
_) Literal Annote
n   -> 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 -> Literal Annote -> Exp Annote
forall l. l -> Literal l -> Exp l
Lit Annote
l Literal Annote
n
                  -- PNPlusK _name _int ->
                  PApp Annote
l QName Annote
n [Pat Annote]
ps             -> (Exp Annote -> Exp Annote -> Exp Annote)
-> Exp Annote -> [Exp Annote] -> Exp Annote
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Annote -> Exp Annote -> Exp Annote -> Exp Annote
forall l. l -> Exp l -> Exp l -> Exp l
App Annote
l) (Annote -> QName Annote -> Exp Annote
forall l. l -> QName l -> Exp l
Con Annote
l QName Annote
n) ([Exp Annote] -> Exp Annote) -> m [Exp Annote] -> m (Exp Annote)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat Annote -> m (Exp Annote)) -> [Pat Annote] -> m [Exp 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 Pat Annote -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Pat Annote -> m (Exp Annote)
patToExp [Pat Annote]
ps
                  PList Annote
l [Pat Annote]
ps              -> Annote -> [Exp Annote] -> Exp Annote
forall l. l -> [Exp l] -> Exp l
List Annote
l ([Exp Annote] -> Exp Annote) -> m [Exp Annote] -> m (Exp Annote)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat Annote -> m (Exp Annote)) -> [Pat Annote] -> m [Exp 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 Pat Annote -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Pat Annote -> m (Exp Annote)
patToExp [Pat Annote]
ps
                  -- PRec _qname _patfields ->
                  PAsPat Annote
_ Name Annote
_ Pat Annote
p            -> Pat Annote -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Pat Annote -> m (Exp Annote)
patToExp Pat Annote
p
                  PIrrPat Annote
_ Pat Annote
p             -> Pat Annote -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Pat Annote -> m (Exp Annote)
patToExp Pat Annote
p
                  PatTypeSig Annote
_ Pat Annote
p Type Annote
_        -> Pat Annote -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Pat Annote -> m (Exp Annote)
patToExp Pat Annote
p
                  -- PViewPat _exp _pat ->
                  PBangPat Annote
_ Pat Annote
p            -> Pat Annote -> m (Exp Annote)
forall (m :: * -> *).
(MonadState Int m, MonadError AstError m) =>
Pat Annote -> m (Exp Annote)
patToExp Pat Annote
p
                  Pat Annote
p                       -> Annote -> Text -> m (Exp Annote)
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (Pat Annote -> Annote
forall l. Pat l -> l
forall (ast :: * -> *) l. Annotated ast => ast l -> l
ann Pat Annote
p) Text
"unsupported pattern."

-- | Turns beta-redexes into cases. E.g.:
--
-- > (\ x -> e2) e1
--
-- becomes
--
-- > case e1 of { x -> e2 }
lambdasToCases :: Monad m => Desugar m
lambdasToCases :: forall (m :: * -> *). Monad m => Desugar m
lambdasToCases = Desugar m
forall a. Monoid a => a
mempty { dsExp = T $ \ case
      App Annote
l (Lambda Annote
_ [Pat Annote
p] Exp Annote
e2) Exp Annote
e1 -> 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 Pat Annote
p (Annote -> Exp Annote -> Rhs Annote
forall l. l -> Exp l -> Rhs l
UnGuardedRhs Annote
l Exp Annote
e2) Maybe (Binds Annote)
forall a. Maybe a
Nothing]
      Exp Annote
e                          -> Exp Annote
e}