{- |
Module                  : Language.Jsonnet.Desugar
Copyright               : (c) 2020-2021 Alexandre Moreno
SPDX-License-Identifier : BSD-3-Clause OR Apache-2.0
Maintainer              : Alexandre Moreno <alexmorenocano@gmail.com>
Stability               : experimental
Portability             : non-portable
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Language.Jsonnet.Desugar (desugar) where

import qualified Data.Bifunctor
import Data.Fix as F
import Data.List.NonEmpty (NonEmpty (..), toList)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T (pack)
import Debug.Trace
import Language.Jsonnet.Annotate
import Language.Jsonnet.Common
import Language.Jsonnet.Core
import Language.Jsonnet.Error
import Language.Jsonnet.Parser.SrcSpan
import Language.Jsonnet.Pretty ()
import Language.Jsonnet.Syntax
import Text.PrettyPrint.ANSI.Leijen hiding (encloseSep, (<$>))
import Unbound.Generics.LocallyNameless

class Desugarer a where
  desugar :: a -> Core

instance Desugarer (Ann ExprF ()) where
  desugar :: Ann ExprF () -> Core
desugar = (Product (Const ((), Bool)) ExprF Core -> Core)
-> Fix (Product (Const ((), Bool)) ExprF) -> Core
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix Product (Const ((), Bool)) ExprF Core -> Core
forall {a}. Product (Const (a, Bool)) ExprF Core -> Core
go (Fix (Product (Const ((), Bool)) ExprF) -> Core)
-> (Ann ExprF () -> Fix (Product (Const ((), Bool)) ExprF))
-> Ann ExprF ()
-> Core
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann ExprF () -> Fix (Product (Const ((), Bool)) ExprF)
forall a. Ann ExprF a -> Ann ExprF (a, Bool)
zipWithOutermost
    where
      go :: Product (Const (a, Bool)) ExprF Core -> Core
go (AnnF ExprF Core
f (a
_, Bool
b)) = Bool -> ExprF Core -> Core
alg Bool
b ExprF Core
f

instance Desugarer (Ann ExprF SrcSpan) where
  desugar :: Ann ExprF SrcSpan -> Core
desugar = (Product (Const (SrcSpan, Bool)) ExprF Core -> Core)
-> Fix (Product (Const (SrcSpan, Bool)) ExprF) -> Core
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix Product (Const (SrcSpan, Bool)) ExprF Core -> Core
go (Fix (Product (Const (SrcSpan, Bool)) ExprF) -> Core)
-> (Ann ExprF SrcSpan
    -> Fix (Product (Const (SrcSpan, Bool)) ExprF))
-> Ann ExprF SrcSpan
-> Core
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann ExprF SrcSpan -> Fix (Product (Const (SrcSpan, Bool)) ExprF)
forall a. Ann ExprF a -> Ann ExprF (a, Bool)
zipWithOutermost
    where
      go :: Product (Const (SrcSpan, Bool)) ExprF Core -> Core
go (AnnF ExprF Core
f (SrcSpan
a, Bool
b)) = SrcSpan -> Core -> Core
CLoc SrcSpan
a (Bool -> ExprF Core -> Core
alg Bool
b ExprF Core
f)

-- | annotate nodes with a boolean denoting outermost objects
zipWithOutermost :: Ann ExprF a -> Ann ExprF (a, Bool)
zipWithOutermost :: forall a. Ann ExprF a -> Ann ExprF (a, Bool)
zipWithOutermost = Fix (AnnF (Product (Const a) ExprF) Bool) -> Ann ExprF (a, Bool)
forall (f :: * -> *) a b.
Functor f =>
Fix (AnnF (AnnF f a) b) -> Ann f (a, b)
annZip (Fix (AnnF (Product (Const a) ExprF) Bool) -> Ann ExprF (a, Bool))
-> (Fix (Product (Const a) ExprF)
    -> Fix (AnnF (Product (Const a) ExprF) Bool))
-> Fix (Product (Const a) ExprF)
-> Ann ExprF (a, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fix (Product (Const a) ExprF) -> Bool -> (Bool, Bool))
-> Bool
-> Fix (Product (Const a) ExprF)
-> Fix (AnnF (Product (Const a) ExprF) Bool)
forall (f :: * -> *) a b.
Functor f =>
(Fix f -> a -> (b, a)) -> a -> Fix f -> Ann f b
inherit Fix (Product (Const a) ExprF) -> Bool -> (Bool, Bool)
forall {a1}. Fix (Product (Const a1) ExprF) -> Bool -> (Bool, Bool)
go Bool
False
  where
    go :: Fix (Product (Const a1) ExprF) -> Bool -> (Bool, Bool)
go (Fix (AnnF EObj {} a1
_)) Bool
False = (Bool
True, Bool
True)
    go (Fix (AnnF EObj {} a1
_)) Bool
True = (Bool
False, Bool
True)
    go Fix (Product (Const a1) ExprF)
_ Bool
x = (Bool
False, Bool
x)

alg :: Bool -> ExprF Core -> Core
alg :: Bool -> ExprF Core -> Core
alg Bool
outermost = \case
  ELit Literal
l -> Literal -> Core
CLit Literal
l
  EIdent Ident
i -> Name Core -> Core
CVar (Ident -> Name Core
forall a. Ident -> Name a
s2n Ident
i)
  EFun [Param Core]
ps Core
e -> [Param Core] -> Core -> Core
desugarFun [Param Core]
ps Core
e
  EApply Core
e Args Core
es -> Core -> Args Core -> Core
CApp Core
e Args Core
es
  ELocal NonEmpty (Ident, Core)
bnds Core
e -> NonEmpty (Ident, Core) -> Core -> Core
desugarLet NonEmpty (Ident, Core)
bnds Core
e
  EBinOp BinOp
Mod Core
e1 Core
e2 ->
    -- operator % is overloaded for both modulo and string formatting
    Text -> Args Core -> Core
stdFunc Text
"mod" ([Arg Core] -> Strictness -> Args Core
forall a. [Arg a] -> Strictness -> Args a
Args [Core -> Arg Core
forall a. a -> Arg a
Pos Core
e1, Core -> Arg Core
forall a. a -> Arg a
Pos Core
e2] Strictness
Lazy)
  EBinOp BinOp
op Core
e1 Core
e2 -> BinOp -> Core -> Core -> Core
desugarBinOp BinOp
op Core
e1 Core
e2
  EUnyOp UnyOp
op Core
e -> UnyOp -> Core -> Core
desugarUnyOp UnyOp
op Core
e
  EIfElse Core
c Core
t Core
e -> Core -> Core -> Core -> Core
desugarIfElse Core
c Core
t Core
e
  EIf Core
c Core
t -> Core -> Core -> Core -> Core
desugarIfElse Core
c Core
t (Literal -> Core
CLit Literal
Null)
  EArr [Core]
e -> [Core] -> Core
CArr [Core]
e
  EObj {[(Ident, Core)]
[EField Core]
fields :: forall a. ExprF a -> [EField a]
locals :: forall a. ExprF a -> [(Ident, a)]
fields :: [EField Core]
locals :: [(Ident, Core)]
..} -> Bool -> [(Ident, Core)] -> [EField Core] -> Core
desugarObj Bool
outermost [(Ident, Core)]
locals [EField Core]
fields
  ELookup Core
e1 Core
e2 -> Core -> Core -> Core
desugarLookup Core
e1 Core
e2
  EIndex Core
e1 Core
e2 -> Core -> Core -> Core
desugarLookup Core
e1 Core
e2
  EErr Core
e -> Core -> Core
desugarErr Core
e
  EAssert Assert Core
e -> Assert Core -> Core
desugarAssert Assert Core
e
  ESlice {Maybe Core
Core
step :: forall a. ExprF a -> Maybe a
end :: forall a. ExprF a -> Maybe a
start :: forall a. ExprF a -> Maybe a
expr :: forall a. ExprF a -> a
step :: Maybe Core
end :: Maybe Core
start :: Maybe Core
expr :: Core
..} -> Core -> Maybe Core -> Maybe Core -> Maybe Core -> Core
desugarSlice Core
expr Maybe Core
start Maybe Core
end Maybe Core
step
  EArrComp {Core
expr :: Core
expr :: forall a. ExprF a -> a
expr, NonEmpty (CompSpec Core)
comp :: forall a. ExprF a -> NonEmpty (CompSpec a)
comp :: NonEmpty (CompSpec Core)
comp} -> Core -> NonEmpty (CompSpec Core) -> Core
desugarArrComp Core
expr NonEmpty (CompSpec Core)
comp
  EObjComp {EField Core
field :: forall a. ExprF a -> EField a
field :: EField Core
field, NonEmpty (CompSpec Core)
comp :: NonEmpty (CompSpec Core)
comp :: forall a. ExprF a -> NonEmpty (CompSpec a)
comp, [(Ident, Core)]
locals :: [(Ident, Core)]
locals :: forall a. ExprF a -> [(Ident, a)]
locals} -> EField Core -> NonEmpty (CompSpec Core) -> [(Ident, Core)] -> Core
desugarObjComp EField Core
field NonEmpty (CompSpec Core)
comp [(Ident, Core)]
locals

desugarSlice :: Core -> Maybe Core -> Maybe Core -> Maybe Core -> Core
desugarSlice Core
expr Maybe Core
start Maybe Core
end Maybe Core
step =
  Text -> Args Core -> Core
stdFunc
    Text
"slice"
    ( [Arg Core] -> Strictness -> Args Core
forall a. [Arg a] -> Strictness -> Args a
Args
        [ Core -> Arg Core
forall a. a -> Arg a
Pos Core
expr,
          Core -> Arg Core
forall a. a -> Arg a
Pos (Core -> Arg Core) -> Core -> Arg Core
forall a b. (a -> b) -> a -> b
$ Maybe Core -> Core
maybeNull Maybe Core
start,
          Core -> Arg Core
forall a. a -> Arg a
Pos (Core -> Arg Core) -> Core -> Arg Core
forall a b. (a -> b) -> a -> b
$ Maybe Core -> Core
maybeNull Maybe Core
end,
          Core -> Arg Core
forall a. a -> Arg a
Pos (Core -> Arg Core) -> Core -> Arg Core
forall a b. (a -> b) -> a -> b
$ Maybe Core -> Core
maybeNull Maybe Core
step
        ]
        Strictness
Lazy
    )
  where
    maybeNull :: Maybe Core -> Core
maybeNull = Core -> Maybe Core -> Core
forall a. a -> Maybe a -> a
fromMaybe (Literal -> Core
CLit Literal
Null)

desugarIfElse :: Core -> Core -> Core -> Core
desugarIfElse :: Core -> Core -> Core -> Core
desugarIfElse Core
c Core
t Core
e = Core -> Args Core -> Core
CApp (Prim -> Core
CPrim Prim
Cond) ([Arg Core] -> Strictness -> Args Core
forall a. [Arg a] -> Strictness -> Args a
Args [Core -> Arg Core
forall a. a -> Arg a
Pos Core
c, Core -> Arg Core
forall a. a -> Arg a
Pos Core
t, Core -> Arg Core
forall a. a -> Arg a
Pos Core
e] Strictness
Lazy)

desugarLookup :: Core -> Core -> Core
desugarLookup :: Core -> Core -> Core
desugarLookup Core
e1 Core
e2 = Core -> Args Core -> Core
CApp (Prim -> Core
CPrim (BinOp -> Prim
BinOp BinOp
Lookup)) ([Arg Core] -> Strictness -> Args Core
forall a. [Arg a] -> Strictness -> Args a
Args [Core -> Arg Core
forall a. a -> Arg a
Pos Core
e1, Core -> Arg Core
forall a. a -> Arg a
Pos Core
e2] Strictness
Lazy)

desugarErr :: Core -> Core
desugarErr :: Core -> Core
desugarErr Core
e = Core -> Args Core -> Core
CApp (Prim -> Core
CPrim (UnyOp -> Prim
UnyOp UnyOp
Err)) ([Arg Core] -> Strictness -> Args Core
forall a. [Arg a] -> Strictness -> Args a
Args [Core -> Arg Core
forall a. a -> Arg a
Pos Core
e] Strictness
Lazy)

desugarBinOp :: BinOp -> Core -> Core -> Core
desugarBinOp :: BinOp -> Core -> Core -> Core
desugarBinOp BinOp
op Core
e1 Core
e2 = Core -> Args Core -> Core
CApp (Prim -> Core
CPrim (BinOp -> Prim
BinOp BinOp
op)) ([Arg Core] -> Strictness -> Args Core
forall a. [Arg a] -> Strictness -> Args a
Args [Core -> Arg Core
forall a. a -> Arg a
Pos Core
e1, Core -> Arg Core
forall a. a -> Arg a
Pos Core
e2] Strictness
Lazy)

desugarUnyOp :: UnyOp -> Core -> Core
desugarUnyOp :: UnyOp -> Core -> Core
desugarUnyOp UnyOp
op Core
e = Core -> Args Core -> Core
CApp (Prim -> Core
CPrim (UnyOp -> Prim
UnyOp UnyOp
op)) ([Arg Core] -> Strictness -> Args Core
forall a. [Arg a] -> Strictness -> Args a
Args [Core -> Arg Core
forall a. a -> Arg a
Pos Core
e] Strictness
Lazy)

desugarObj :: Bool -> [(Ident, Core)] -> [EField Core] -> Core
desugarObj Bool
outermost [(Ident, Core)]
locals [EField Core]
fields = Core
obj
  where
    obj :: Core
obj = [CField] -> Core
CObj (EField Core -> CField
desugarField (EField Core -> CField) -> [EField Core] -> [CField]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [EField Core]
fields')

    bnds :: [(Ident, Core)]
bnds =
      if Bool
outermost
        then (Ident
"$", Name Core -> Core
CVar Name Core
"self") (Ident, Core) -> [(Ident, Core)] -> [(Ident, Core)]
forall a. a -> [a] -> [a]
: [(Ident, Core)]
locals
        else [(Ident, Core)]
locals

    f :: Core -> Core
f v :: Core
v@(CLit Literal
_) = Core
v
    f v :: Core
v@(CLoc SrcSpan
_ (CLit Literal
_)) = Core
v
    f Core
v = case [(Ident, Core)]
bnds of
      [] -> Core
v
      [(Ident, Core)]
xs -> NonEmpty (Ident, Core) -> Core -> Core
desugarLet ([(Ident, Core)] -> NonEmpty (Ident, Core)
forall a. [a] -> NonEmpty a
NE.fromList [(Ident, Core)]
xs) Core
v

    fields' :: [EField Core]
fields' =
      (\(EField Core
key Core
val Visibility
v Bool
o) -> Core -> Core -> Visibility -> Bool -> EField Core
forall a. a -> a -> Visibility -> Bool -> EField a
EField Core
key (Core -> Core
f Core
val) Visibility
v Bool
o) (EField Core -> EField Core) -> [EField Core] -> [EField Core]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [EField Core]
fields

desugarAssert :: Assert Core -> Core
desugarAssert :: Assert Core -> Core
desugarAssert (Assert Core
c Maybe Core
m Core
e) =
  Core -> Core -> Core -> Core
desugarIfElse
    Core
c
    Core
e
    ( Core -> Core
desugarErr (Core -> Core) -> Core -> Core
forall a b. (a -> b) -> a -> b
$
        Core -> Maybe Core -> Core
forall a. a -> Maybe a -> a
fromMaybe
          (Literal -> Core
CLit (Literal -> Core) -> Literal -> Core
forall a b. (a -> b) -> a -> b
$ Text -> Literal
String Text
"Assertion failed")
          Maybe Core
m
    )

desugarArrComp :: Core -> NonEmpty (CompSpec Core) -> Core
desugarArrComp :: Core -> NonEmpty (CompSpec Core) -> Core
desugarArrComp Core
expr = (CompSpec Core -> Core -> Core)
-> Core -> NonEmpty (CompSpec Core) -> Core
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CompSpec Core -> Core -> Core
f ([Core] -> Core
CArr [Item [Core]
Core
expr])
  where
    f :: CompSpec Core -> Core -> Core
f CompSpec {Ident
Maybe Core
Core
ifspec :: forall a. CompSpec a -> Maybe a
forspec :: forall a. CompSpec a -> a
var :: forall a. CompSpec a -> Ident
ifspec :: Maybe Core
forspec :: Core
var :: Ident
..} Core
e =
      Comp -> Core -> Core
CComp (Bind (Name Core) (Core, Maybe Core) -> Comp
ArrC (Name Core
-> (Core, Maybe Core) -> Bind (Name Core) (Core, Maybe Core)
forall p t. (Alpha p, Alpha t) => p -> t -> Bind p t
bind (Ident -> Name Core
forall a. Ident -> Name a
s2n Ident
var) (Core
e, Maybe Core
ifspec))) Core
forspec

desugarField :: EField Core -> CField
desugarField :: EField Core -> CField
desugarField EField {Bool
Visibility
Core
override :: forall a. EField a -> Bool
visibility :: forall a. EField a -> Visibility
value :: forall a. EField a -> a
key :: forall a. EField a -> a
override :: Bool
visibility :: Visibility
value :: Core
key :: Core
..} = Core -> Core -> Visibility -> CField
mkField Core
key Core
value' Visibility
visibility
  where
    value' :: Core
value' =
      if Bool
override
        then
          Core -> Core -> Core -> Core
desugarIfElse
            (BinOp -> Core -> Core -> Core
desugarBinOp BinOp
In Core
key Core
super)
            (BinOp -> Core -> Core -> Core
desugarBinOp BinOp
Add (Core -> Core -> Core
desugarLookup Core
super Core
key) Core
value)
            Core
value
        else Core
value
    super :: Core
super = Name Core -> Core
CVar (Name Core -> Core) -> Name Core -> Core
forall a b. (a -> b) -> a -> b
$ Ident -> Name Core
forall a. Ident -> Name a
s2n Ident
"super"

desugarObjComp :: EField Core -> NonEmpty (CompSpec Core) -> [(Ident, Core)] -> Core
desugarObjComp EField {Bool
Visibility
Core
override :: Bool
visibility :: Visibility
value :: Core
key :: Core
override :: forall a. EField a -> Bool
visibility :: forall a. EField a -> Visibility
value :: forall a. EField a -> a
key :: forall a. EField a -> a
..} NonEmpty (CompSpec Core)
comp [(Ident, Core)]
locals =
  Comp -> Core -> Core
CComp (Bind (Name Core) (CField, Maybe Core) -> Comp
ObjC (Name Core
-> (CField, Maybe Core) -> Bind (Name Core) (CField, Maybe Core)
forall p t. (Alpha p, Alpha t) => p -> t -> Bind p t
bind (Ident -> Name Core
forall a. Ident -> Name a
s2n Ident
"arr") (CField
kv', Maybe Core
forall a. Maybe a
Nothing))) Core
arrComp
  where
    kv' :: CField
kv' =
      EField Core -> CField
desugarField
        ( EField :: forall a. a -> a -> Visibility -> Bool -> EField a
EField
            { key :: Core
key = Core
key',
              value :: Core
value = Core
value',
              Visibility
visibility :: Visibility
visibility :: Visibility
visibility,
              Bool
override :: Bool
override :: Bool
override
            }
        )
    bnds :: NonEmpty (Ident, Core)
bnds = NonEmpty Ident -> NonEmpty Core -> NonEmpty (Ident, Core)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip ((CompSpec Core -> Ident)
-> NonEmpty (CompSpec Core) -> NonEmpty Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompSpec Core -> Ident
forall a. CompSpec a -> Ident
var NonEmpty (CompSpec Core)
comp) NonEmpty Core
xs
    key' :: Core
key' = NonEmpty (Ident, Core) -> Core -> Core
desugarLet NonEmpty (Ident, Core)
bnds Core
key
    value' :: Core
value' = case [(Ident, Core)]
locals of
      [] -> NonEmpty (Ident, Core) -> Core -> Core
desugarLet NonEmpty (Ident, Core)
bnds Core
value
      -- we need to nest the let bindings due to the impl.
      [(Ident, Core)]
xs -> NonEmpty (Ident, Core) -> Core -> Core
desugarLet NonEmpty (Ident, Core)
bnds (Core -> Core) -> Core -> Core
forall a b. (a -> b) -> a -> b
$ NonEmpty (Ident, Core) -> Core -> Core
desugarLet ([(Ident, Core)] -> NonEmpty (Ident, Core)
forall a. [a] -> NonEmpty a
NE.fromList [(Ident, Core)]
xs) Core
value
    xs :: NonEmpty Core
xs = Core -> Core -> Core
desugarLookup (Name Core -> Core
CVar (Name Core -> Core) -> Name Core -> Core
forall a b. (a -> b) -> a -> b
$ Ident -> Name Core
forall a. Ident -> Name a
s2n Ident
"arr") (Core -> Core) -> (Integer -> Core) -> Integer -> Core
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Core
CLit (Literal -> Core) -> (Integer -> Literal) -> Integer -> Core
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Literal
Number (Scientific -> Literal)
-> (Integer -> Scientific) -> Integer -> Literal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Core) -> NonEmpty Integer -> NonEmpty Core
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Item (NonEmpty Integer)
0 ..]
    arrComp :: Core
arrComp = Core -> NonEmpty (CompSpec Core) -> Core
desugarArrComp Core
arr NonEmpty (CompSpec Core)
comp
    arr :: Core
arr = [Core] -> Core
CArr ([Core] -> Core) -> [Core] -> Core
forall a b. (a -> b) -> a -> b
$ NonEmpty Core -> [Core]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Core -> [Core]) -> NonEmpty Core -> [Core]
forall a b. (a -> b) -> a -> b
$ Name Core -> Core
CVar (Name Core -> Core)
-> (CompSpec Core -> Name Core) -> CompSpec Core -> Core
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Name Core
forall a. Ident -> Name a
s2n (Ident -> Name Core)
-> (CompSpec Core -> Ident) -> CompSpec Core -> Name Core
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompSpec Core -> Ident
forall a. CompSpec a -> Ident
var (CompSpec Core -> Core)
-> NonEmpty (CompSpec Core) -> NonEmpty Core
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (CompSpec Core)
comp

stdFunc :: Text -> Args Core -> Core
stdFunc :: Text -> Args Core -> Core
stdFunc Text
f =
  Core -> Args Core -> Core
CApp
    ( Core -> Core -> Core
desugarLookup
        (Name Core -> Core
CVar Name Core
"std")
        (Literal -> Core
CLit (Literal -> Core) -> Literal -> Core
forall a b. (a -> b) -> a -> b
$ Text -> Literal
String Text
f)
    )

desugarFun :: [Param Core] -> Core -> Core
desugarFun [Param Core]
ps Core
e =
  Lam -> Core
CLam (Lam -> Core) -> Lam -> Core
forall a b. (a -> b) -> a -> b
$
    Rec [(Name Core, Embed Core)] -> Core -> Lam
forall p t. (Alpha p, Alpha t) => p -> t -> Bind p t
bind
      ( [(Name Core, Embed Core)] -> Rec [(Name Core, Embed Core)]
forall p. Alpha p => p -> Rec p
rec ([(Name Core, Embed Core)] -> Rec [(Name Core, Embed Core)])
-> [(Name Core, Embed Core)] -> Rec [(Name Core, Embed Core)]
forall a b. (a -> b) -> a -> b
$
          (Param Core -> (Name Core, Embed Core))
-> [Param Core] -> [(Name Core, Embed Core)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ( \(Ident
n, Maybe Core
a) ->
                (Ident -> Name Core
forall a. Ident -> Name a
s2n Ident
n, Core -> Embed Core
forall t. t -> Embed t
Embed (Core -> Maybe Core -> Core
forall a. a -> Maybe a -> a
fromMaybe (Ident -> Core
forall {a}. Pretty a => a -> Core
errNotBound Ident
n) Maybe Core
a))
            )
            [Param Core]
ps
      )
      Core
e
  where
    errNotBound :: a -> Core
errNotBound a
n =
      Core -> Core
desugarErr (Core -> Core) -> Core -> Core
forall a b. (a -> b) -> a -> b
$
        Literal -> Core
CLit (Literal -> Core) -> Literal -> Core
forall a b. (a -> b) -> a -> b
$
          Text -> Literal
String
            ( Ident -> Text
T.pack (Ident -> Text) -> Ident -> Text
forall a b. (a -> b) -> a -> b
$
                Doc -> Ident
forall a. Show a => a -> Ident
show (Doc -> Ident) -> Doc -> Ident
forall a b. (a -> b) -> a -> b
$
                  EvalError -> Doc
forall a. Pretty a => a -> Doc
pretty (EvalError -> Doc) -> EvalError -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> EvalError
ParamNotBound (a -> Doc
forall a. Pretty a => a -> Doc
pretty a
n)
            )

desugarLet :: NonEmpty (Ident, Core) -> Core -> Core
desugarLet NonEmpty (Ident, Core)
bnds Core
e =
  Lam -> Core
CLet (Lam -> Core) -> Lam -> Core
forall a b. (a -> b) -> a -> b
$
    Rec [(Name Core, Embed Core)] -> Core -> Lam
forall p t. (Alpha p, Alpha t) => p -> t -> Bind p t
bind
      ( [(Name Core, Embed Core)] -> Rec [(Name Core, Embed Core)]
forall p. Alpha p => p -> Rec p
rec ([(Name Core, Embed Core)] -> Rec [(Name Core, Embed Core)])
-> [(Name Core, Embed Core)] -> Rec [(Name Core, Embed Core)]
forall a b. (a -> b) -> a -> b
$
          NonEmpty (Name Core, Embed Core) -> [(Name Core, Embed Core)]
forall a. NonEmpty a -> [a]
toList
            ( ((Ident, Core) -> (Name Core, Embed Core))
-> NonEmpty (Ident, Core) -> NonEmpty (Name Core, Embed Core)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                ( (Ident -> Name Core)
-> (Core -> Embed Core) -> (Ident, Core) -> (Name Core, Embed Core)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
Data.Bifunctor.bimap Ident -> Name Core
forall a. Ident -> Name a
s2n Core -> Embed Core
forall t. t -> Embed t
Embed
                )
                NonEmpty (Ident, Core)
bnds
            )
      )
      Core
e