{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

{- | Lower the representation of a sslang Ast into sslang IR.

This pass expects prior desugaring passes to ensure that:

- Op regions are unflatted into proper applications.
- Patterns in definitions consist of only (annotated) identifiers or wildcards.
-}
module IR.LowerAst (
  lowerProgram,
) where

import qualified Common.Compiler as Compiler
import Common.Identifiers (
  HasFreeVars (..),
  TVarId (..),
  fromId,
  fromString,
  isCons,
  isVar,
 )
import qualified Front.Ast as A
import qualified IR.IR as I
import qualified IR.Types as I

import Control.Monad (unless)
import Data.Bifunctor (Bifunctor (..))
import Data.Generics (everything, mkQ)
import Data.Maybe (fromMaybe)
import qualified Data.Set as S
import IR.Types.Type (tupleId)


-- | Unannotated terms appear as an empty stack.
untyped :: I.Annotations
untyped :: Annotations
untyped = Annotations
forall a. Monoid a => a
mempty


-- | Construct a single annotation.
ann :: I.Annotation -> I.Annotations
ann :: Annotation -> Annotations
ann Annotation
t = [Annotation] -> Annotations
I.Annotations [Annotation
t]


-- | Construct a single annotation from a 'I.Type'.
annType :: I.Type -> I.Annotations
annType :: Type -> Annotations
annType = Annotation -> Annotations
ann (Annotation -> Annotations)
-> (Type -> Annotation) -> Type -> Annotations
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Annotation
I.AnnType


-- | Lower an AST 'Program' into IR.
lowerProgram :: A.Program -> Compiler.Pass (I.Program I.Annotations)
lowerProgram :: Program -> Pass (Program Annotations)
lowerProgram p :: Program
p@(A.Program [TopDef]
ds) = do
  let ([TypeDef]
tds, [String]
cds, [ExternDecl]
xds, [Definition]
dds) = [TopDef] -> ([TypeDef], [String], [ExternDecl], [Definition])
A.getTops [TopDef]
ds
  [(TConId, TypeDef)]
tds' <- [(TConId, TypeDef)] -> [(TConId, TypeDef)] -> [(TConId, TypeDef)]
forall a. [a] -> [a] -> [a]
(++) ([(TConId, TypeDef)] -> [(TConId, TypeDef)] -> [(TConId, TypeDef)])
-> Pass [(TConId, TypeDef)]
-> Pass ([(TConId, TypeDef)] -> [(TConId, TypeDef)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Program -> Pass [(TConId, TypeDef)]
lowerTupleDefs Program
p Pass ([(TConId, TypeDef)] -> [(TConId, TypeDef)])
-> Pass [(TConId, TypeDef)] -> Pass [(TConId, TypeDef)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TypeDef -> Pass (TConId, TypeDef))
-> [TypeDef] -> Pass [(TConId, TypeDef)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeDef -> Pass (TConId, TypeDef)
lowerTypeDef [TypeDef]
tds
  [(VarId, Type)]
xds' <- (ExternDecl -> Pass (VarId, Type))
-> [ExternDecl] -> Pass [(VarId, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExternDecl -> Pass (VarId, Type)
lowerExternDecl [ExternDecl]
xds
  [(Binder Annotations, Expr Annotations)]
dds' <- (Definition -> Pass (Binder Annotations, Expr Annotations))
-> [Definition] -> Pass [(Binder Annotations, Expr Annotations)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Definition -> Pass (Binder Annotations, Expr Annotations)
lowerDef [Definition]
dds
  Program Annotations -> Pass (Program Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Program Annotations -> Pass (Program Annotations))
-> Program Annotations -> Pass (Program Annotations)
forall a b. (a -> b) -> a -> b
$
    Program :: forall t.
VarId
-> String
-> [(VarId, Type)]
-> [(Binder t, Expr t)]
-> [(TConId, TypeDef)]
-> Map VarId (SymInfo t)
-> Program t
I.Program
      { programEntry :: VarId
I.programEntry = String -> VarId
forall a. IsString a => String -> a
fromString String
"main" -- TODO: don't hardcode
      , programDefs :: [(Binder Annotations, Expr Annotations)]
I.programDefs = [(Binder Annotations, Expr Annotations)]
dds'
      , externDecls :: [(VarId, Type)]
I.externDecls = [(VarId, Type)]
xds'
      , typeDefs :: [(TConId, TypeDef)]
I.typeDefs = [(TConId, TypeDef)]
tds'
      , cDefs :: String
I.cDefs = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
cds
      , symTable :: Map VarId (SymInfo Annotations)
I.symTable = Map VarId (SymInfo Annotations)
forall t. Map VarId (SymInfo t)
I.uninitializedSymTable
      }


lowerTypeDef :: A.TypeDef -> Compiler.Pass (I.TConId, I.TypeDef)
lowerTypeDef :: TypeDef -> Pass (TConId, TypeDef)
lowerTypeDef TypeDef
td = do
  [(DConId, TypeVariant)]
tds <- (TypeVariant -> Pass (DConId, TypeVariant))
-> [TypeVariant] -> Pass [(DConId, TypeVariant)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeVariant -> Pass (DConId, TypeVariant)
lowerTypeVariant ([TypeVariant] -> Pass [(DConId, TypeVariant)])
-> [TypeVariant] -> Pass [(DConId, TypeVariant)]
forall a b. (a -> b) -> a -> b
$ TypeDef -> [TypeVariant]
A.typeVariants TypeDef
td
  (TConId, TypeDef) -> Pass (TConId, TypeDef)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Identifier -> TConId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId (Identifier -> TConId) -> Identifier -> TConId
forall a b. (a -> b) -> a -> b
$ TypeDef -> Identifier
A.typeName TypeDef
td
    , TypeDef :: [(DConId, TypeVariant)] -> [TVarId] -> TypeDef
I.TypeDef{targs :: [TVarId]
I.targs = (Identifier -> TVarId) -> [Identifier] -> [TVarId]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> TVarId
TVarId ([Identifier] -> [TVarId]) -> [Identifier] -> [TVarId]
forall a b. (a -> b) -> a -> b
$ TypeDef -> [Identifier]
A.typeParams TypeDef
td, variants :: [(DConId, TypeVariant)]
I.variants = [(DConId, TypeVariant)]
tds}
    )
 where
  lowerTypeVariant ::
    A.TypeVariant -> Compiler.Pass (I.DConId, I.TypeVariant)
  lowerTypeVariant :: TypeVariant -> Pass (DConId, TypeVariant)
lowerTypeVariant (A.VariantUnnamed Identifier
vn [Typ]
ts) =
    (Identifier -> DConId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
vn,) (TypeVariant -> (DConId, TypeVariant))
-> ([Type] -> TypeVariant) -> [Type] -> (DConId, TypeVariant)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> TypeVariant
I.VariantUnnamed ([Type] -> (DConId, TypeVariant))
-> Pass [Type] -> Pass (DConId, TypeVariant)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typ -> Pass Type) -> [Typ] -> Pass [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Typ -> Pass Type
lowerType [Typ]
ts


lowerTupleDefs :: A.Program -> Compiler.Pass [(I.TConId, I.TypeDef)]
lowerTupleDefs :: Program -> Pass [(TConId, TypeDef)]
lowerTupleDefs Program
dds = [(TConId, TypeDef)] -> Pass [(TConId, TypeDef)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(TConId, TypeDef)] -> Pass [(TConId, TypeDef)])
-> [(TConId, TypeDef)] -> Pass [(TConId, TypeDef)]
forall a b. (a -> b) -> a -> b
$ (Int -> (TConId, TypeDef)) -> [Int] -> [(TConId, TypeDef)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (TConId, TypeDef)
lowerTupleDef ([Int] -> [(TConId, TypeDef)]) -> [Int] -> [(TConId, TypeDef)]
forall a b. (a -> b) -> a -> b
$ Set Int -> [Int]
forall a. Set a -> [a]
S.toList Set Int
tupleSizes
 where
  tupleSizes :: S.Set Int
  tupleSizes :: Set Int
tupleSizes =
    -- This is so hilariously inefficient but I tell myself it's ok
    (Set Int -> Set Int -> Set Int)
-> GenericQ (Set Int) -> Program -> Set Int
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
S.union (Set Int -> (Expr -> Set Int) -> a -> Set Int
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Set Int
forall a. Set a
S.empty Expr -> Set Int
dconTupleLen) Program
dds
      Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`S.union` (Set Int -> Set Int -> Set Int)
-> GenericQ (Set Int) -> Program -> Set Int
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
S.union (Set Int -> (Pat -> Set Int) -> a -> Set Int
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Set Int
forall a. Set a
S.empty Pat -> Set Int
patTupleLen) Program
dds
      Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`S.union` (Set Int -> Set Int -> Set Int)
-> GenericQ (Set Int) -> Program -> Set Int
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
S.union (Set Int -> (Typ -> Set Int) -> a -> Set Int
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Set Int
forall a. Set a
S.empty Typ -> Set Int
typeTupleLen) Program
dds

  dconTupleLen :: A.Expr -> S.Set Int
  dconTupleLen :: Expr -> Set Int
dconTupleLen (A.Tuple [Expr]
es) = Int -> Set Int
forall a. a -> Set a
S.singleton (Int -> Set Int) -> Int -> Set Int
forall a b. (a -> b) -> a -> b
$ [Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
es
  dconTupleLen (A.Par [Expr]
es) = Int -> Set Int
forall a. a -> Set a
S.singleton (Int -> Set Int) -> Int -> Set Int
forall a b. (a -> b) -> a -> b
$ [Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
es
  dconTupleLen Expr
_ = Set Int
forall a. Set a
S.empty

  patTupleLen :: A.Pat -> S.Set Int
  patTupleLen :: Pat -> Set Int
patTupleLen (A.PatTup [Pat]
es) = Int -> Set Int
forall a. a -> Set a
S.singleton (Int -> Set Int) -> Int -> Set Int
forall a b. (a -> b) -> a -> b
$ [Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
es
  patTupleLen Pat
_ = Set Int
forall a. Set a
S.empty

  typeTupleLen :: A.Typ -> S.Set Int
  typeTupleLen :: Typ -> Set Int
typeTupleLen (A.TTuple [Typ]
tys) = Int -> Set Int
forall a. a -> Set a
S.singleton (Int -> Set Int) -> Int -> Set Int
forall a b. (a -> b) -> a -> b
$ [Typ] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Typ]
tys
  typeTupleLen Typ
_ = Set Int
forall a. Set a
S.empty

  lowerTupleDef :: Int -> (I.TConId, I.TypeDef)
  lowerTupleDef :: Int -> (TConId, TypeDef)
lowerTupleDef Int
i =
    let targs :: [TVarId]
targs = (Int -> TVarId) -> [Int] -> [TVarId]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier -> TVarId
TVarId (Identifier -> TVarId) -> (Int -> Identifier) -> Int -> TVarId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier
forall a. IsString a => String -> a
fromString (String -> Identifier) -> (Int -> String) -> Int -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"tup" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"arg") String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [Int
1 .. Int
i]
     in ( Int -> TConId
forall v. Identifiable v => Int -> v
tupleId Int
i
        , TypeDef :: [(DConId, TypeVariant)] -> [TVarId] -> TypeDef
I.TypeDef
            { targs :: [TVarId]
I.targs = [TVarId]
targs
            , variants :: [(DConId, TypeVariant)]
I.variants = [(Int -> DConId
forall v. Identifiable v => Int -> v
tupleId Int
i, [Type] -> TypeVariant
I.VariantUnnamed ([Type] -> TypeVariant) -> [Type] -> TypeVariant
forall a b. (a -> b) -> a -> b
$ (TVarId -> Type) -> [TVarId] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TVarId -> Type
I.TVar [TVarId]
targs)]
            }
        )


lowerExternDecl :: A.ExternDecl -> Compiler.Pass (I.VarId, I.Type)
lowerExternDecl :: ExternDecl -> Pass (VarId, Type)
lowerExternDecl (A.ExternDecl Identifier
i Typ
t) = (Identifier -> VarId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
i,) (Type -> (VarId, Type)) -> Pass Type -> Pass (VarId, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typ -> Pass Type
lowerType Typ
t


-- | Lower an 'A.Definition' into a name and bound expression.
lowerDef :: A.Definition -> Compiler.Pass (I.Binder I.Annotations, I.Expr I.Annotations)
lowerDef :: Definition -> Pass (Binder Annotations, Expr Annotations)
lowerDef (A.DefPat Pat
aPat Expr
aBody) = do
  -- NOTE: this does not handle patterns in aPat, but that should be handled by
  -- an earlier desugaring pass anyway.
  Binder Annotations
n <- Pat -> Pass (Binder Annotations)
patToBinder Pat
aPat
  Expr Annotations
b <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
aBody
  (Binder Annotations, Expr Annotations)
-> Pass (Binder Annotations, Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Binder Annotations
n, Expr Annotations
b)
lowerDef (A.DefFn Identifier
aName [Pat]
aArgs (A.TypProper Typ
ty) Expr
aBody) = do
  Annotation
typAnn <- Type -> Annotation
I.AnnType (Type -> Annotation) -> Pass Type -> Pass Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typ -> Pass Type
lowerType Typ
ty
  Expr Annotations
b <- [Pat] -> Expr -> Type -> Pass (Expr Annotations)
lowerCurry [Pat]
aArgs Expr
aBody Type
I.Hole
  (Binder Annotations, Expr Annotations)
-> Pass (Binder Annotations, Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (VarId -> Annotations -> Binder Annotations
forall t. VarId -> t -> Binder t
I.BindVar (Identifier -> VarId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
aName) (Annotation -> Annotations
ann Annotation
typAnn), Expr Annotations
b)
lowerDef (A.DefFn Identifier
aName [Pat]
aArgs (A.TypReturn Typ
retTy) Expr
aBody) = do
  Type
ty <- Typ -> Pass Type
lowerType Typ
retTy
  Expr Annotations
b <- [Pat] -> Expr -> Type -> Pass (Expr Annotations)
lowerCurry [Pat]
aArgs Expr
aBody Type
ty
  (Binder Annotations, Expr Annotations)
-> Pass (Binder Annotations, Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (VarId -> Annotations -> Binder Annotations
forall t. VarId -> t -> Binder t
I.BindVar (Identifier -> VarId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
aName) Annotations
untyped, Expr Annotations
b)
lowerDef (A.DefFn Identifier
aName [Pat]
aArgs TypFn
A.TypNone Expr
aBody) = do
  Expr Annotations
b <- [Pat] -> Expr -> Type -> Pass (Expr Annotations)
lowerCurry [Pat]
aArgs Expr
aBody Type
I.Hole
  (Binder Annotations, Expr Annotations)
-> Pass (Binder Annotations, Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (VarId -> Annotations -> Binder Annotations
forall t. VarId -> t -> Binder t
I.BindVar (Identifier -> VarId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
aName) Annotations
untyped, Expr Annotations
b)


-- | Curry and lower a list of arguments to a lambda body.
lowerCurry :: [A.Pat] -> A.Expr -> I.Type -> Compiler.Pass (I.Expr I.Annotations)
lowerCurry :: [Pat] -> Expr -> Type -> Pass (Expr Annotations)
lowerCurry [Pat]
aPats Expr
aBody Type
retType = do
  -- All the type variables in the binders here share the same scope, but they
  -- will be scattered across different lambdas if we naively fold here.
  -- Instead, we will leave all the binders untyped, and attach a single,
  -- combined annotation to the overall lambda body.
  [Binder Annotations]
binders <- (Pat -> Pass (Binder Annotations))
-> [Pat] -> Pass [Binder Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> Pass (Binder Annotations)
patToBinder [Pat]
aPats
  [Type]
annotations <- (Maybe Type -> Type) -> [Maybe Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Maybe Type -> Type
forall a. a -> Maybe a -> a
fromMaybe Type
I.Hole) ([Maybe Type] -> [Type]) -> Pass [Maybe Type] -> Pass [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> Pass (Maybe Type)) -> [Pat] -> Pass [Maybe Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> Pass (Maybe Type)
patToTopType [Pat]
aPats
  Expr Annotations
body <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
aBody

  let lambdaExpr :: Expr Annotations
lambdaExpr = (Binder Annotations -> Expr Annotations -> Expr Annotations)
-> Expr Annotations -> [Binder Annotations] -> Expr Annotations
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Binder Annotations
v Expr Annotations
b -> Binder Annotations
-> Expr Annotations -> Annotations -> Expr Annotations
forall t. Binder t -> Expr t -> t -> Expr t
I.Lambda Binder Annotations
v Expr Annotations
b Annotations
untyped) Expr Annotations
body [Binder Annotations]
binders
      lambdaAnn :: Type
lambdaAnn = ([Type], Type) -> Type
I.foldArrow ([Type]
annotations, Type
retType)

  Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$
    if (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
I.Hole) (Type
retType Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
annotations)
      then Expr Annotations
lambdaExpr
      else Annotations -> Expr Annotations -> Expr Annotations
forall a (c :: * -> *). (Semigroup a, Carrier c) => a -> c a -> c a
I.injectMore (Type -> Annotations
annType Type
lambdaAnn) Expr Annotations
lambdaExpr


{- | Extract a 'I.Binder' from an Ast pattern.

 Type annotations with free type variables are discarded.
-}
patToBinder :: A.Pat -> Compiler.Pass (I.Binder I.Annotations)
patToBinder :: Pat -> Pass (Binder Annotations)
patToBinder (A.PatId Identifier
v) = Binder Annotations -> Pass (Binder Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Binder Annotations -> Pass (Binder Annotations))
-> Binder Annotations -> Pass (Binder Annotations)
forall a b. (a -> b) -> a -> b
$ VarId -> Annotations -> Binder Annotations
forall t. VarId -> t -> Binder t
I.BindVar (Identifier -> VarId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
v) Annotations
untyped
patToBinder Pat
A.PatWildcard = Binder Annotations -> Pass (Binder Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Binder Annotations -> Pass (Binder Annotations))
-> Binder Annotations -> Pass (Binder Annotations)
forall a b. (a -> b) -> a -> b
$ Annotations -> Binder Annotations
forall t. t -> Binder t
I.BindAnon Annotations
untyped
patToBinder (A.PatAnn Typ
annTy Pat
pat) = do
  Type
t <- Typ -> Pass Type
lowerType Typ
annTy
  Binder Annotations
p <- Pat -> Pass (Binder Annotations)
patToBinder Pat
pat
  Binder Annotations -> Pass (Binder Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Binder Annotations -> Pass (Binder Annotations))
-> Binder Annotations -> Pass (Binder Annotations)
forall a b. (a -> b) -> a -> b
$
    if Set TVarId -> Bool
forall a. Set a -> Bool
S.null (Set TVarId -> Bool) -> Set TVarId -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Set TVarId
forall t i. HasFreeVars t i => t -> Set i
freeVars Type
t
      then Annotations -> Binder Annotations -> Binder Annotations
forall a (c :: * -> *). (Semigroup a, Carrier c) => a -> c a -> c a
I.injectMore (Type -> Annotations
annType Type
t) Binder Annotations
p
      else Binder Annotations
p
patToBinder Pat
p = String -> Pass (Binder Annotations)
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.unexpected (String -> Pass (Binder Annotations))
-> String -> Pass (Binder Annotations)
forall a b. (a -> b) -> a -> b
$ String
"patToBinder: non-binder pattern" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pat -> String
forall a. Show a => a -> String
show Pat
p


-- | Get possible top-level annotation from pattern; ignores nested annotations.
patToTopType :: A.Pat -> Compiler.Pass (Maybe I.Type)
patToTopType :: Pat -> Pass (Maybe Type)
patToTopType (A.PatAnn Typ
t Pat
_) = Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Pass Type -> Pass (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typ -> Pass Type
lowerType Typ
t
patToTopType Pat
_ = Maybe Type -> Pass (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing


{- | Lowers an AST expression into an IR expression.

Performs the following desugaring inline:

-   Desugars 'A.IfElse' to 'I.Match'
-   Unrolls 'A.Constraint' to annotate sub-expressions
-}
lowerExpr :: A.Expr -> Compiler.Pass (I.Expr I.Annotations)
lowerExpr :: Expr -> Pass (Expr Annotations)
lowerExpr (Expr -> Maybe Primitive
lowerPrim -> Just Primitive
p) = Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
p [] Annotations
untyped
lowerExpr (A.Id Identifier
v)
  | Identifier -> Bool
forall a. Identifiable a => a -> Bool
isCons Identifier
v = Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ DConId -> Annotations -> Expr Annotations
forall t. DConId -> t -> Expr t
I.Data (Identifier -> DConId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
v) Annotations
untyped
  | Bool
otherwise = Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ VarId -> Annotations -> Expr Annotations
forall t. VarId -> t -> Expr t
I.Var (Identifier -> VarId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
v) Annotations
untyped
lowerExpr (A.Lit Literal
l) = Literal -> Annotations -> Expr Annotations
forall t. Literal -> t -> Expr t
I.Lit (Literal -> Annotations -> Expr Annotations)
-> Pass Literal -> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> Pass Literal
lowerLit Literal
l Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerExpr a :: Expr
a@(A.Apply Expr
l Expr
r) = case (Expr -> Maybe Primitive)
-> (Expr, [Expr]) -> (Maybe Primitive, [Expr])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Expr -> Maybe Primitive
lowerPrim (Expr -> (Expr, [Expr])
A.collectApp Expr
a) of
  (Just Primitive
prim, [Expr]
args) -> Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
prim ([Expr Annotations] -> Annotations -> Expr Annotations)
-> Pass [Expr Annotations]
-> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Pass (Expr Annotations))
-> [Expr] -> Pass [Expr Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr -> Pass (Expr Annotations)
lowerExpr [Expr]
args Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
  (Maybe Primitive
Nothing, [Expr]
_) -> Expr Annotations
-> Expr Annotations -> Annotations -> Expr Annotations
forall t. Expr t -> Expr t -> t -> Expr t
I.App (Expr Annotations
 -> Expr Annotations -> Annotations -> Expr Annotations)
-> Pass (Expr Annotations)
-> Pass (Expr Annotations -> Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Pass (Expr Annotations)
lowerExpr Expr
l Pass (Expr Annotations -> Annotations -> Expr Annotations)
-> Pass (Expr Annotations)
-> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Pass (Expr Annotations)
lowerExpr Expr
r Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerExpr (A.Let [Definition]
ds Expr
b) =
  [(Binder Annotations, Expr Annotations)]
-> Expr Annotations -> Annotations -> Expr Annotations
forall t. [(Binder t, Expr t)] -> Expr t -> t -> Expr t
I.Let ([(Binder Annotations, Expr Annotations)]
 -> Expr Annotations -> Annotations -> Expr Annotations)
-> Pass [(Binder Annotations, Expr Annotations)]
-> Pass (Expr Annotations -> Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Definition -> Pass (Binder Annotations, Expr Annotations))
-> [Definition] -> Pass [(Binder Annotations, Expr Annotations)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Definition -> Pass (Binder Annotations, Expr Annotations)
lowerDef [Definition]
ds Pass (Expr Annotations -> Annotations -> Expr Annotations)
-> Pass (Expr Annotations)
-> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Pass (Expr Annotations)
lowerExpr Expr
b Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerExpr (A.Lambda [Pat]
ps Expr
b) = do
  [Pat] -> Expr -> Type -> Pass (Expr Annotations)
lowerCurry [Pat]
ps Expr
b Type
I.Hole
lowerExpr (A.While Expr
c Expr
b) = do
  Expr Annotations
body <- Expr -> Pass (Expr Annotations)
lowerExpr (Expr -> Expr -> Expr -> Expr
A.IfElse Expr
c (Literal -> Expr
A.Lit Literal
A.LitEvent) Expr
A.Break Expr -> Expr -> Expr
`A.Seq` Expr
b)
  Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
I.Loop [Expr Annotations
body] Annotations
untyped
lowerExpr (A.Loop Expr
b) = do
  Expr Annotations
body <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
b
  Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
I.Loop [Expr Annotations
body] Annotations
untyped
lowerExpr (A.Par [Expr]
es) = Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
I.Par ([Expr Annotations] -> Annotations -> Expr Annotations)
-> Pass [Expr Annotations]
-> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Pass (Expr Annotations))
-> [Expr] -> Pass [Expr Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr -> Pass (Expr Annotations)
lowerExpr [Expr]
es Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerExpr (A.After Expr
delay Expr
lhs Expr
rhs) =
  Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
I.After ([Expr Annotations] -> Annotations -> Expr Annotations)
-> Pass [Expr Annotations]
-> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Pass (Expr Annotations))
-> [Expr] -> Pass [Expr Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr -> Pass (Expr Annotations)
lowerExpr [Expr
delay, Expr
lhs, Expr
rhs] Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerExpr (A.Assign Expr
lhs Expr
rhs) =
  Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
I.Assign ([Expr Annotations] -> Annotations -> Expr Annotations)
-> Pass [Expr Annotations]
-> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Pass (Expr Annotations))
-> [Expr] -> Pass [Expr Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr -> Pass (Expr Annotations)
lowerExpr [Expr
lhs, Expr
rhs] Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerExpr (A.Constraint Expr
e Typ
ty) = do
  Expr Annotations
e' <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
e
  Annotation
ty' <- Type -> Annotation
I.AnnType (Type -> Annotation) -> Pass Type -> Pass Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typ -> Pass Type
lowerType Typ
ty
  Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Annotations -> Expr Annotations -> Expr Annotations
forall a (c :: * -> *). (Semigroup a, Carrier c) => a -> c a -> c a
I.injectMore (Annotation -> Annotations
ann Annotation
ty') Expr Annotations
e'
lowerExpr (A.Wait [Expr]
exprs) =
  Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
I.Wait ([Expr Annotations] -> Annotations -> Expr Annotations)
-> Pass [Expr Annotations]
-> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Pass (Expr Annotations))
-> [Expr] -> Pass [Expr Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr -> Pass (Expr Annotations)
lowerExpr [Expr]
exprs Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerExpr (A.Seq Expr
l Expr
r) = do
  Expr Annotations
l' <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
l
  Expr Annotations
r' <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
r
  Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ [(Binder Annotations, Expr Annotations)]
-> Expr Annotations -> Annotations -> Expr Annotations
forall t. [(Binder t, Expr t)] -> Expr t -> t -> Expr t
I.Let [(Annotations -> Binder Annotations
forall t. t -> Binder t
I.BindAnon (Annotations -> Binder Annotations)
-> Annotations -> Binder Annotations
forall a b. (a -> b) -> a -> b
$ Expr Annotations -> Annotations
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Annotations
l', Expr Annotations
l')] Expr Annotations
r' Annotations
untyped
lowerExpr Expr
A.Break = Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
I.Break [] Annotations
untyped
lowerExpr (A.IfElse Expr
c Expr
t Expr
e) = do
  Expr Annotations
c' <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
c
  Expr Annotations
t' <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
t
  Expr Annotations
e' <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
e
  let altT :: (Alt Annotations, Expr Annotations)
altT = (Binder Annotations -> Alt Annotations
forall t. Binder t -> Alt t
I.AltBinder (Binder Annotations -> Alt Annotations)
-> Binder Annotations -> Alt Annotations
forall a b. (a -> b) -> a -> b
$ Annotations -> Binder Annotations
forall t. t -> Binder t
I.BindAnon (Annotations -> Binder Annotations)
-> Annotations -> Binder Annotations
forall a b. (a -> b) -> a -> b
$ Expr Annotations -> Annotations
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Annotations
t', Expr Annotations
t')
      altE :: (Alt Annotations, Expr Annotations)
altE = (Literal -> Annotations -> Alt Annotations
forall t. Literal -> t -> Alt t
I.AltLit (Integer -> Literal
I.LitIntegral Integer
0) (Annotations -> Alt Annotations) -> Annotations -> Alt Annotations
forall a b. (a -> b) -> a -> b
$ Expr Annotations -> Annotations
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Annotations
e', Expr Annotations
e')
  Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Expr Annotations
-> [(Alt Annotations, Expr Annotations)]
-> Annotations
-> Expr Annotations
forall t. Expr t -> [(Alt t, Expr t)] -> t -> Expr t
I.Match Expr Annotations
c' [(Alt Annotations, Expr Annotations)
altE, (Alt Annotations, Expr Annotations)
altT] Annotations
untyped
lowerExpr (A.CQuote String
s) = Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim (String -> Primitive
I.CQuote (String -> Primitive) -> String -> Primitive
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. IsString a => String -> a
fromString String
s) [] Annotations
untyped
lowerExpr (A.CCall Identifier
s [Expr]
es) =
  Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim (CSym -> Primitive
I.CCall (CSym -> Primitive) -> CSym -> Primitive
forall a b. (a -> b) -> a -> b
$ Identifier -> CSym
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
s) ([Expr Annotations] -> Annotations -> Expr Annotations)
-> Pass [Expr Annotations]
-> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Pass (Expr Annotations))
-> [Expr] -> Pass [Expr Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr -> Pass (Expr Annotations)
lowerExpr [Expr]
es Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerExpr Expr
A.NoExpr = Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Literal -> Annotations -> Expr Annotations
forall t. Literal -> t -> Expr t
I.Lit Literal
I.LitEvent Annotations
untyped
lowerExpr (A.OpRegion Expr
_ OpRegion
_) =
  String -> Pass (Expr Annotations)
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.unexpected String
"lowerExpr: OpRegions should have already been desugared"
lowerExpr (A.Match Expr
s [(Pat, Expr)]
ps) =
  Expr Annotations
-> [(Alt Annotations, Expr Annotations)]
-> Annotations
-> Expr Annotations
forall t. Expr t -> [(Alt t, Expr t)] -> t -> Expr t
I.Match (Expr Annotations
 -> [(Alt Annotations, Expr Annotations)]
 -> Annotations
 -> Expr Annotations)
-> Pass (Expr Annotations)
-> Pass
     ([(Alt Annotations, Expr Annotations)]
      -> Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr -> Pass (Expr Annotations)
lowerExpr Expr
s Pass
  ([(Alt Annotations, Expr Annotations)]
   -> Annotations -> Expr Annotations)
-> Pass [(Alt Annotations, Expr Annotations)]
-> Pass (Annotations -> Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Pat, Expr) -> Pass (Alt Annotations, Expr Annotations))
-> [(Pat, Expr)] -> Pass [(Alt Annotations, Expr Annotations)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Pat, Expr) -> Pass (Alt Annotations, Expr Annotations)
lowerArm [(Pat, Expr)]
ps Pass (Annotations -> Expr Annotations)
-> Pass Annotations -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
 where
  lowerArm :: (Pat, Expr) -> Pass (Alt Annotations, Expr Annotations)
lowerArm (Pat
a, Expr
e) = (,) (Alt Annotations
 -> Expr Annotations -> (Alt Annotations, Expr Annotations))
-> Pass (Alt Annotations)
-> Pass (Expr Annotations -> (Alt Annotations, Expr Annotations))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> Pass (Alt Annotations)
lowerPatAlt Pat
a Pass (Expr Annotations -> (Alt Annotations, Expr Annotations))
-> Pass (Expr Annotations)
-> Pass (Alt Annotations, Expr Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr -> Pass (Expr Annotations)
lowerExpr Expr
e
lowerExpr (A.Tuple [Expr]
es) =
  Expr Annotations -> [Expr Annotations] -> Expr Annotations
apply_recurse (DConId -> Annotations -> Expr Annotations
forall t. DConId -> t -> Expr t
I.Data (Identifier -> DConId
I.DConId (Int -> Identifier
forall v. Identifiable v => Int -> v
tupleId (Int -> Identifier) -> Int -> Identifier
forall a b. (a -> b) -> a -> b
$ [Expr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr]
es)) Annotations
untyped) ([Expr Annotations] -> Expr Annotations)
-> Pass [Expr Annotations] -> Pass (Expr Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Pass (Expr Annotations))
-> [Expr] -> Pass [Expr Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr -> Pass (Expr Annotations)
lowerExpr [Expr]
es
 where
  apply_recurse :: Expr Annotations -> [Expr Annotations] -> Expr Annotations
apply_recurse Expr Annotations
e [] = Expr Annotations
e
  apply_recurse Expr Annotations
e (Expr Annotations
x : [Expr Annotations]
xs) = Expr Annotations -> [Expr Annotations] -> Expr Annotations
apply_recurse (Expr Annotations
-> Expr Annotations -> Annotations -> Expr Annotations
forall t. Expr t -> Expr t -> t -> Expr t
I.App Expr Annotations
e Expr Annotations
x Annotations
untyped) [Expr Annotations]
xs
lowerExpr (A.Last Expr
e) = do
  Expr Annotations
e' <- Expr -> Pass (Expr Annotations)
lowerExpr Expr
e
  Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
I.Last [Expr Annotations
e'] Annotations
untyped
lowerExpr Expr
A.Now = Expr Annotations -> Pass (Expr Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Annotations -> Pass (Expr Annotations))
-> Expr Annotations -> Pass (Expr Annotations)
forall a b. (a -> b) -> a -> b
$ Primitive -> [Expr Annotations] -> Annotations -> Expr Annotations
forall t. Primitive -> [Expr t] -> t -> Expr t
I.Prim Primitive
I.Now [] Annotations
untyped
lowerExpr (A.ListExpr [Expr]
_) =
  String -> Pass (Expr Annotations)
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.unexpected String
"lowerExpr: ListExprs should have already been desugared"


-- | Lower an A.Pat into an I.Alt
lowerPatAlt :: A.Pat -> Compiler.Pass (I.Alt I.Annotations)
lowerPatAlt :: Pat -> Pass (Alt Annotations)
lowerPatAlt Pat
A.PatWildcard = Alt Annotations -> Pass (Alt Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Alt Annotations -> Pass (Alt Annotations))
-> Alt Annotations -> Pass (Alt Annotations)
forall a b. (a -> b) -> a -> b
$ Binder Annotations -> Alt Annotations
forall t. Binder t -> Alt t
I.AltBinder (Binder Annotations -> Alt Annotations)
-> Binder Annotations -> Alt Annotations
forall a b. (a -> b) -> a -> b
$ Annotations -> Binder Annotations
forall t. t -> Binder t
I.BindAnon Annotations
untyped
lowerPatAlt (A.PatId Identifier
i)
  | Identifier -> Bool
forall a. Identifiable a => a -> Bool
isVar Identifier
i = Alt Annotations -> Pass (Alt Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Alt Annotations -> Pass (Alt Annotations))
-> Alt Annotations -> Pass (Alt Annotations)
forall a b. (a -> b) -> a -> b
$ Binder Annotations -> Alt Annotations
forall t. Binder t -> Alt t
I.AltBinder (Binder Annotations -> Alt Annotations)
-> Binder Annotations -> Alt Annotations
forall a b. (a -> b) -> a -> b
$ VarId -> Annotations -> Binder Annotations
forall t. VarId -> t -> Binder t
I.BindVar (Identifier -> VarId
I.VarId Identifier
i) Annotations
untyped
  | Bool
otherwise = Alt Annotations -> Pass (Alt Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Alt Annotations -> Pass (Alt Annotations))
-> Alt Annotations -> Pass (Alt Annotations)
forall a b. (a -> b) -> a -> b
$ DConId -> [Alt Annotations] -> Annotations -> Alt Annotations
forall t. DConId -> [Alt t] -> t -> Alt t
I.AltData (Identifier -> DConId
I.DConId Identifier
i) [] Annotations
untyped
lowerPatAlt (A.PatLit Literal
l) = Literal -> Annotations -> Alt Annotations
forall t. Literal -> t -> Alt t
I.AltLit (Literal -> Annotations -> Alt Annotations)
-> Pass Literal -> Pass (Annotations -> Alt Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal -> Pass Literal
lowerLit Literal
l Pass (Annotations -> Alt Annotations)
-> Pass Annotations -> Pass (Alt Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerPatAlt (A.PatTup [Pat]
ps) =
  DConId -> [Alt Annotations] -> Annotations -> Alt Annotations
forall t. DConId -> [Alt t] -> t -> Alt t
I.AltData (Int -> DConId
forall v. Identifiable v => Int -> v
I.tupleId (Int -> DConId) -> Int -> DConId
forall a b. (a -> b) -> a -> b
$ [Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
ps) ([Alt Annotations] -> Annotations -> Alt Annotations)
-> Pass [Alt Annotations] -> Pass (Annotations -> Alt Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> Pass (Alt Annotations)) -> [Pat] -> Pass [Alt Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> Pass (Alt Annotations)
lowerPatAlt [Pat]
ps Pass (Annotations -> Alt Annotations)
-> Pass Annotations -> Pass (Alt Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
lowerPatAlt p :: Pat
p@(A.PatApp [Pat]
_) = case Pat -> (Pat, [Pat])
A.collectPApp Pat
p of
  (A.PatId Identifier
i, [Pat]
ps) | Identifier -> Bool
forall a. Identifiable a => a -> Bool
isCons Identifier
i -> DConId -> [Alt Annotations] -> Annotations -> Alt Annotations
forall t. DConId -> [Alt t] -> t -> Alt t
I.AltData (Identifier -> DConId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
i) ([Alt Annotations] -> Annotations -> Alt Annotations)
-> Pass [Alt Annotations] -> Pass (Annotations -> Alt Annotations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> Pass (Alt Annotations)) -> [Pat] -> Pass [Alt Annotations]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Pat -> Pass (Alt Annotations)
lowerPatAlt [Pat]
ps Pass (Annotations -> Alt Annotations)
-> Pass Annotations -> Pass (Alt Annotations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotations -> Pass Annotations
forall (f :: * -> *) a. Applicative f => a -> f a
pure Annotations
untyped
  (Pat, [Pat])
_ -> String -> Pass (Alt Annotations)
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.unexpected String
"lowerPatAlt: app head should be a data constructor"
lowerPatAlt (A.PatAnn Typ
typ Pat
p) = do
  Type
t <- Typ -> Pass Type
lowerType Typ
typ
  Bool -> Pass () -> Pass ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set TVarId -> Bool
forall a. Set a -> Bool
S.null (Set TVarId -> Bool) -> Set TVarId -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Set TVarId
forall t i. HasFreeVars t i => t -> Set i
freeVars Type
t) (Pass () -> Pass ()) -> Pass () -> Pass ()
forall a b. (a -> b) -> a -> b
$ do
    String -> Pass ()
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.todo String
"Pattern annotations with type variables are not yet supported"
  Alt Annotations
a <- Pat -> Pass (Alt Annotations)
lowerPatAlt Pat
p
  Alt Annotations -> Pass (Alt Annotations)
forall (m :: * -> *) a. Monad m => a -> m a
return (Alt Annotations -> Pass (Alt Annotations))
-> Alt Annotations -> Pass (Alt Annotations)
forall a b. (a -> b) -> a -> b
$ Annotations -> Alt Annotations -> Alt Annotations
forall a (c :: * -> *). (Semigroup a, Carrier c) => a -> c a -> c a
I.injectMore (Annotation -> Annotations
ann (Annotation -> Annotations) -> Annotation -> Annotations
forall a b. (a -> b) -> a -> b
$ Type -> Annotation
I.AnnType Type
t) Alt Annotations
a
lowerPatAlt (A.PatAs Identifier
_ Pat
_) =
  String -> Pass (Alt Annotations)
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.todo String
"lowerPatAlt cannot handle aliases yet"


-- | Lower an AST literal into an IR literal.
lowerLit :: A.Literal -> Compiler.Pass I.Literal
lowerLit :: Literal -> Pass Literal
lowerLit (A.LitInt Integer
i) = Literal -> Pass Literal
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> Pass Literal) -> Literal -> Pass Literal
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
I.LitIntegral Integer
i
lowerLit Literal
A.LitEvent = Literal -> Pass Literal
forall (m :: * -> *) a. Monad m => a -> m a
return Literal
I.LitEvent
lowerLit (A.LitChar Char
_c) = String -> Pass Literal
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.todo String
"Char literals are not yet implemented"
lowerLit (A.LitString String
_s) =
  String -> Pass Literal
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.unexpected String
"lowerLit: LitStrings should have already been desugared"
lowerLit (A.LitRat Rational
_r) =
  String -> Pass Literal
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.todo String
"Rational literals are not yet implemented"


-- | Translate an AST identifier into the corresponding IR primitive, if any.
lowerPrim :: A.Expr -> Maybe I.Primitive
lowerPrim :: Expr -> Maybe Primitive
lowerPrim (A.Id Identifier
"new") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just Primitive
I.New
lowerPrim (A.Id Identifier
"deref") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just Primitive
I.Deref
lowerPrim (A.Id Identifier
"now") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just Primitive
I.Now
lowerPrim (A.Id Identifier
"+") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimAdd
lowerPrim (A.Id Identifier
"-") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimSub
lowerPrim (A.Id Identifier
"*") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimMul
lowerPrim (A.Id Identifier
"/") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimDiv
lowerPrim (A.Id Identifier
"%") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimMod
lowerPrim (A.Id Identifier
"==") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimEq
lowerPrim (A.Id Identifier
"!=") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimNeq
lowerPrim (A.Id Identifier
">=") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimGe
lowerPrim (A.Id Identifier
"<=") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimLe
lowerPrim (A.Id Identifier
">") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimGt
lowerPrim (A.Id Identifier
"<") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimLt
lowerPrim (A.Id Identifier
"!") = Primitive -> Maybe Primitive
forall a. a -> Maybe a
Just (Primitive -> Maybe Primitive) -> Primitive -> Maybe Primitive
forall a b. (a -> b) -> a -> b
$ PrimOp -> Primitive
I.PrimOp PrimOp
I.PrimNot
lowerPrim Expr
_ = Maybe Primitive
forall a. Maybe a
Nothing


-- | Lowers the AST's representation of types into that of the IR.
lowerType :: A.Typ -> Compiler.Pass I.Type
lowerType :: Typ -> Pass Type
lowerType (A.TCon Identifier
"Int") = Type -> Pass Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
I.I32
lowerType (A.TCon Identifier
"Time") = Type -> Pass Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
I.U64
lowerType (A.TCon Identifier
"()") = Type -> Pass Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
I.Unit
lowerType (A.TCon Identifier
i)
  | Identifier -> Bool
forall a. Identifiable a => a -> Bool
isCons Identifier
i = Type -> Pass Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Pass Type) -> Type -> Pass Type
forall a b. (a -> b) -> a -> b
$ TConId -> [Type] -> Type
I.TCon (Identifier -> TConId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
i) []
  | Bool
otherwise = Type -> Pass Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Pass Type) -> Type -> Pass Type
forall a b. (a -> b) -> a -> b
$ TVarId -> Type
I.TVar (Identifier -> TVarId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
i)
lowerType (A.TTuple [Typ]
tys) = [Type] -> Type
I.tuple ([Type] -> Type) -> Pass [Type] -> Pass Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typ -> Pass Type) -> [Typ] -> Pass [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Typ -> Pass Type
lowerType [Typ]
tys
lowerType (A.TArrow Typ
lhs Typ
rhs) = Type -> Type -> Type
I.Arrow (Type -> Type -> Type) -> Pass Type -> Pass (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typ -> Pass Type
lowerType Typ
lhs Pass (Type -> Type) -> Pass Type -> Pass Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Typ -> Pass Type
lowerType Typ
rhs
lowerType a :: Typ
a@(A.TApp Typ
_ Typ
_) = case Typ -> (Typ, [Typ])
A.collectTApp Typ
a of
  (A.TCon Identifier
"&", [Typ
arg]) -> Type -> Type
I.Ref (Type -> Type) -> Pass Type -> Pass Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typ -> Pass Type
lowerType Typ
arg
  (A.TCon Identifier
"[]", [Typ
arg]) -> Type -> Type
I.List (Type -> Type) -> Pass Type -> Pass Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typ -> Pass Type
lowerType Typ
arg
  (A.TCon Identifier
i, [Typ]
args) | Identifier -> Bool
forall a. Identifiable a => a -> Bool
isCons Identifier
i -> TConId -> [Type] -> Type
I.TCon (Identifier -> TConId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId Identifier
i) ([Type] -> Type) -> Pass [Type] -> Pass Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typ -> Pass Type) -> [Typ] -> Pass [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Typ -> Pass Type
lowerType [Typ]
args
  (Typ, [Typ])
_ ->
    String -> Pass Type
forall (m :: * -> *) a. MonadError Error m => String -> m a
Compiler.unexpected (String -> Pass Type) -> String -> Pass Type
forall a b. (a -> b) -> a -> b
$
      String
"lowerType cannot type application with non-constant head: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Typ -> String
forall a. Show a => a -> String
show Typ
a