{-# 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)
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 ->
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
[(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