{- | Translate Giml to JavaScript

-}

{-# language OverloadedStrings #-}
{-# language ConstraintKinds #-}
{-# language FlexibleContexts #-}
{-# language ViewPatterns #-}

module Language.Giml.Compiler.Translate where

import Utils
import qualified Data.Text as T
import qualified Data.Map as M
import Control.Monad.State
import Control.Monad.Reader

import Language.Giml.Syntax.Ast
import Language.Giml.Types.Infer (Ann(..))
import Language.Giml.Builtins
import qualified Language.Backend.JS as JS

-- Types and utilities --

type TranState = Int
type Translate m =
  ( MonadState TranState m
  , MonadReader Builtins m
  )

genVar :: Translate m => T.Text -> m Var
genVar :: Text -> m Text
genVar Text
prefix = do
  TranState
n <- m TranState
forall s (m :: * -> *). MonadState s m => m s
get
  (TranState -> TranState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (TranState -> TranState -> TranState
forall a. Num a => a -> a -> a
+TranState
1)
  Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (TranState -> String
forall a. Show a => a -> String
show TranState
n))

translate :: (a -> StateT TranState (Reader Builtins) b) -> Builtins -> a -> b
translate :: (a -> StateT TranState (Reader Builtins) b) -> Builtins -> a -> b
translate a -> StateT TranState (Reader Builtins) b
tran Builtins
built =
  ( (Reader Builtins b -> Builtins -> b)
-> Builtins -> Reader Builtins b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader Builtins b -> Builtins -> b
forall r a. Reader r a -> r -> a
runReader Builtins
built
  (Reader Builtins b -> b) -> (a -> Reader Builtins b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT TranState (Reader Builtins) b
 -> TranState -> Reader Builtins b)
-> TranState
-> StateT TranState (Reader Builtins) b
-> Reader Builtins b
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT TranState (Reader Builtins) b
-> TranState -> Reader Builtins b
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT TranState
0
  (StateT TranState (Reader Builtins) b -> Reader Builtins b)
-> (a -> StateT TranState (Reader Builtins) b)
-> a
-> Reader Builtins b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateT TranState (Reader Builtins) b
tran
  )

-- Translation --

translateFile :: Translate m => File Ann -> m JS.File
translateFile :: File Ann -> m File
translateFile (File [Datatype Ann]
_typedefs [[TermDef Ann]]
termdefs) = do
  let
    -- we don't need to compile data type definitions
    defs :: [TermDef Ann]
defs = [[TermDef Ann]] -> [TermDef Ann]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TermDef Ann]]
termdefs

  ([Statement] -> File) -> m [Statement] -> m File
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Statement] -> File
JS.File (m [Statement] -> m File) -> m [Statement] -> m File
forall a b. (a -> b) -> a -> b
$ [Statement] -> [Statement] -> [Statement]
forall a. Semigroup a => a -> a -> a
(<>)
    ([Statement] -> [Statement] -> [Statement])
-> m [Statement] -> m ([Statement] -> [Statement])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TermDef Ann -> m Statement) -> [TermDef Ann] -> m [Statement]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Definition -> Statement) -> m Definition -> m Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Definition -> Statement
JS.SDef (m Definition -> m Statement)
-> (TermDef Ann -> m Definition) -> TermDef Ann -> m Statement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermDef Ann -> m Definition
forall (m :: * -> *). Translate m => TermDef Ann -> m Definition
translateDef) [TermDef Ann]
defs
    m ([Statement] -> [Statement]) -> m [Statement] -> m [Statement]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Statement] -> m [Statement]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      [ Expr -> Statement
JS.SExpr (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ Expr -> [Expr] -> Expr
JS.EFunCall (Text -> Expr
JS.EVar Text
"main") []
      | [TermDef Ann] -> Bool
hasMain [TermDef Ann]
defs
      ]

hasMain :: [TermDef Ann] -> Bool
hasMain :: [TermDef Ann] -> Bool
hasMain =
  (TermDef Ann -> Bool) -> [TermDef Ann] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
    ( \case
      Variable Ann
_ Text
"main" Expr Ann
_ ->
        Bool
True
      TermDef Ann
_ ->
        Bool
False
    )


translateDef :: Translate m => TermDef Ann -> m JS.Definition
translateDef :: TermDef Ann -> m Definition
translateDef = \case
  Variable Ann
_ Text
var Expr Ann
expr ->
    Text -> Expr -> Definition
JS.Variable Text
var (Expr -> Definition) -> m Expr -> m Definition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
expr
  Function Ann
_ Text
var [Maybe Text]
args Expr Ann
body ->
    Text -> [Text] -> [Statement] -> Definition
JS.Function Text
var ((Maybe Text -> Text) -> [Maybe Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"_") [Maybe Text]
args) ([Statement] -> Definition)
-> (Expr -> [Statement]) -> Expr -> Definition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Statement -> [Statement]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement -> [Statement])
-> (Expr -> Statement) -> Expr -> [Statement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Statement
JS.SRet (Expr -> Definition) -> m Expr -> m Definition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
body

translateBlock :: Translate m => Block Ann -> m JS.Block
translateBlock :: Block Ann -> m [Statement]
translateBlock Block Ann
stmts =
  case Block Ann -> Block Ann
forall a. [a] -> [a]
reverse Block Ann
stmts of
    [] -> [Statement] -> m [Statement]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    SExpr Ann
_ Expr Ann
expr : Block Ann
rest ->
      ([Statement] -> [Statement]) -> m [Statement] -> m [Statement]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Statement] -> [Statement]
forall a. [a] -> [a]
reverse (m [Statement] -> m [Statement]) -> m [Statement] -> m [Statement]
forall a b. (a -> b) -> a -> b
$ (:)
        (Statement -> [Statement] -> [Statement])
-> m Statement -> m ([Statement] -> [Statement])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr -> Statement
JS.SRet (Expr -> Statement) -> m Expr -> m Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr (Expr Ann -> [Expr Ann] -> Expr Ann
forall a. Expr a -> [Expr a] -> Expr a
EFunCall Expr Ann
expr []))
        m ([Statement] -> [Statement]) -> m [Statement] -> m [Statement]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Statement Ann -> m Statement) -> Block Ann -> m [Statement]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Statement Ann -> m Statement
forall (m :: * -> *). Translate m => Statement Ann -> m Statement
translateStmt Block Ann
rest
    Block Ann
_ ->
      (Statement Ann -> m Statement) -> Block Ann -> m [Statement]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Statement Ann -> m Statement
forall (m :: * -> *). Translate m => Statement Ann -> m Statement
translateStmt Block Ann
stmts

translateStmt :: Translate m => Statement Ann -> m JS.Statement
translateStmt :: Statement Ann -> m Statement
translateStmt = \case
  SExpr Ann
_ Expr Ann
expr ->
    Expr -> Statement
JS.SExpr (Expr -> Statement) -> m Expr -> m Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr (Expr Ann -> [Expr Ann] -> Expr Ann
forall a. Expr a -> [Expr a] -> Expr a
EFunCall Expr Ann
expr [])
  SDef Ann
_ TermDef Ann
def ->
    Definition -> Statement
JS.SDef (Definition -> Statement) -> m Definition -> m Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermDef Ann -> m Definition
forall (m :: * -> *). Translate m => TermDef Ann -> m Definition
translateDef TermDef Ann
def
  SBind Ann
ann Text
name Expr Ann
expr -> do
    Definition -> Statement
JS.SDef (Definition -> Statement) -> m Definition -> m Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermDef Ann -> m Definition
forall (m :: * -> *). Translate m => TermDef Ann -> m Definition
translateDef (Ann -> Text -> Expr Ann -> TermDef Ann
forall a. a -> Text -> Expr a -> TermDef a
Variable Ann
ann Text
name (Expr Ann -> [Expr Ann] -> Expr Ann
forall a. Expr a -> [Expr a] -> Expr a
EFunCall Expr Ann
expr []))

translateExpr :: Translate m => Expr Ann -> m JS.Expr
translateExpr :: Expr Ann -> m Expr
translateExpr = \case
  ELit Lit
lit ->
    Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Lit -> Expr
JS.ELit (Lit -> Lit
translateLit Lit
lit)

  EVar Text
var -> do
    Maybe Builtin
mbuiltin <- (Builtins -> Maybe Builtin) -> m (Maybe Builtin)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Text -> Builtins -> Maybe Builtin
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
var)
    case Maybe Builtin
mbuiltin of
      Maybe Builtin
Nothing ->
        Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Expr
JS.EVar Text
var
      Just Builtin{ bImpl :: Builtin -> Impl
bImpl = Impl
impl } ->
        case Impl
impl of
          Func Text
fun ->
            Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Text -> Expr
JS.ERaw Text
fun
          BinOp Text
op ->
            Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ [Text] -> [Statement] -> Expr
JS.EFun [Text
"x"]
              [ Expr -> Statement
JS.SRet (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ [Text] -> [Statement] -> Expr
JS.EFun [Text
"y"]
                [ Expr -> Statement
JS.SRet (Text -> Expr -> Expr -> Expr
JS.EBinOp Text
op (Text -> Expr
JS.EVar Text
"x") (Text -> Expr
JS.EVar Text
"y")) ]
              ]

  EFun [Maybe Text]
args Expr Ann
body ->
    [Text] -> [Statement] -> Expr
JS.EFun ((Maybe Text -> Text) -> [Maybe Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"_") [Maybe Text]
args) ([Statement] -> Expr) -> (Expr -> [Statement]) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Statement -> [Statement]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement -> [Statement])
-> (Expr -> Statement) -> Expr -> [Statement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Statement
JS.SRet (Expr -> Expr) -> m Expr -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
body

  EFunCall Expr Ann
fun [Expr Ann]
args ->
    Expr -> [Expr] -> Expr
JS.EFunCall
      (Expr -> [Expr] -> Expr) -> m Expr -> m ([Expr] -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
fun
      m ([Expr] -> Expr) -> m [Expr] -> m Expr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expr Ann -> m Expr) -> [Expr Ann] -> m [Expr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr [Expr Ann]
args

  EOpenVariant Text
tag ->
    Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> (Statement -> Expr) -> Statement -> m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Statement] -> Expr
JS.EFun [Text
"_data"] ([Statement] -> Expr)
-> (Statement -> [Statement]) -> Statement -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Statement -> [Statement]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement -> m Expr) -> Statement -> m Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Statement
JS.SRet (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ Record Expr -> Expr
JS.ERecord (Record Expr -> Expr) -> Record Expr -> Expr
forall a b. (a -> b) -> a -> b
$ [(Text, Expr)] -> Record Expr
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      [ (Text
"_constr", Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Lit
JS.LString Text
tag)
      , (Text
"_field", Text -> Expr
JS.EVar Text
"_data")
      ]

  EAnnotated (Ann InputAnn
_ Type
t) (EVariant Text
tag)
    | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"True" ->
      Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Lit -> Expr
JS.ELit (Bool -> Lit
JS.LBool Bool
True)
    | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"False" ->
      Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Lit -> Expr
JS.ELit (Bool -> Lit
JS.LBool Bool
False)
    | TypeApp (TypeApp (TypeCon Text
"->") Type
_) Type
_ <- Type
t ->
      Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> (Statement -> Expr) -> Statement -> m Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Statement] -> Expr
JS.EFun [Text
"_data"] ([Statement] -> Expr)
-> (Statement -> [Statement]) -> Statement -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Statement -> [Statement]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement -> m Expr) -> Statement -> m Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Statement
JS.SRet (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ Record Expr -> Expr
JS.ERecord (Record Expr -> Expr) -> Record Expr -> Expr
forall a b. (a -> b) -> a -> b
$ [(Text, Expr)] -> Record Expr
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        [ (Text
"_constr", Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Lit
JS.LString Text
tag)
        , (Text
"_field", Text -> Expr
JS.EVar Text
"_data")
        ]
    | Bool
otherwise ->
      Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Record Expr -> Expr
JS.ERecord (Record Expr -> Expr) -> Record Expr -> Expr
forall a b. (a -> b) -> a -> b
$ [(Text, Expr)] -> Record Expr
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
        [ (Text
"_constr", Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Lit
JS.LString Text
tag)
        , (Text
"_field", Record Expr -> Expr
JS.ERecord Record Expr
forall a. Monoid a => a
mempty)
        ]

  ERecord Record (Expr Ann)
record ->
    Record Expr -> Expr
JS.ERecord (Record Expr -> Expr) -> m (Record Expr) -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Ann -> m Expr) -> Record (Expr Ann) -> m (Record Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Record (Expr Ann)
record

  ERecordAccess Expr Ann
expr Text
label ->
    Expr -> Text -> Expr
JS.ERecordAccess
      (Expr -> Text -> Expr) -> m Expr -> m (Text -> Expr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
expr
      m (Text -> Expr) -> m Text -> m Expr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
label

  ERecordExtension Record (Expr Ann)
record Expr Ann
expr -> do
    Expr
expr' <- Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
expr
    Record Expr
record' <- (Expr Ann -> m Expr) -> Record (Expr Ann) -> m (Record Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Record (Expr Ann)
record
    let
      fun :: Expr
fun = [Text] -> [Statement] -> Expr
JS.EFun [Text
"_record"] ([Statement] -> Expr) -> [Statement] -> Expr
forall a b. (a -> b) -> a -> b
$ [[Statement]] -> [Statement]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ Text -> Expr -> Statement
JS.SRecordClone Text
"_record_copy" (Text -> Expr
JS.EVar Text
"_record") ]
        , ((Text, Expr) -> Statement) -> [(Text, Expr)] -> [Statement]
forall a b. (a -> b) -> [a] -> [b]
map
          (\(Text
lbl, Expr
val) -> Text -> Text -> Expr -> Statement
JS.SRecordAssign Text
"_record_copy" Text
lbl Expr
val)
          (Record Expr -> [(Text, Expr)]
forall k a. Map k a -> [(k, a)]
M.toList Record Expr
record')
        , [ Expr -> Statement
JS.SRet (Text -> Expr
JS.EVar Text
"_record_copy") ]
        ]
    Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Expr -> [Expr] -> Expr
JS.EFunCall Expr
fun [Expr
expr']

  EIf Expr Ann
cond Expr Ann
trueBranch Expr Ann
falseBranch -> do
    Expr
cond' <- Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
cond
    Expr
trueBranch' <- Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
trueBranch
    Expr
falseBranch' <- Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
falseBranch
    Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Expr -> [Expr] -> Expr
JS.EFunCall
      ( [Text] -> [Statement] -> Expr
JS.EFun []
        [ Expr -> [Statement] -> Statement
JS.SIf Expr
cond' [ Expr -> Statement
JS.SRet Expr
trueBranch' ]
        , Expr -> [Statement] -> Statement
JS.SIf (Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Bool -> Lit
JS.LBool Bool
True) [ Expr -> Statement
JS.SRet Expr
falseBranch' ]
        ]
      )
      []

  ECase Expr Ann
expr [(Pattern, Expr Ann)]
patterns -> do
    Expr
expr' <- Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
expr
    Text
var <- Text -> m Text
forall (m :: * -> *). Translate m => Text -> m Text
genVar Text
"case"
    [Statement]
patterns' <- Expr -> [(Pattern, Expr Ann)] -> m [Statement]
forall (m :: * -> *).
Translate m =>
Expr -> [(Pattern, Expr Ann)] -> m [Statement]
translatePatterns (Text -> Expr
JS.EVar Text
var) [(Pattern, Expr Ann)]
patterns
    Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ Expr -> [Expr] -> Expr
JS.EFunCall
      ([Text] -> [Statement] -> Expr
JS.EFun [Text
var] [Statement]
patterns')
      [Expr
expr']

  EFfi Text
fun Maybe Type
typ [Expr Ann]
args ->
    case Maybe Type
typ of
      Maybe Type
Nothing ->
        [Text] -> [Statement] -> Expr
JS.EFun [] ([Statement] -> Expr) -> ([Expr] -> [Statement]) -> [Expr] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Statement -> [Statement]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement -> [Statement])
-> ([Expr] -> Statement) -> [Expr] -> [Statement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Statement
JS.SRet (Expr -> Statement) -> ([Expr] -> Expr) -> [Expr] -> Statement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [Expr] -> Expr
JS.EFunCall (Text -> Expr
JS.EVar Text
fun) ([Expr] -> Expr) -> m [Expr] -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Ann -> m Expr) -> [Expr Ann] -> m [Expr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr [Expr Ann]
args
      Just (Type -> ([Type], Type)
toTypeFun -> ([Type]
_, Type
tret))
        | TypeApp (TypeCon Text
"IO") Type
_ <- Type
tret ->
          [Text] -> [Statement] -> Expr
JS.EFun [] ([Statement] -> Expr) -> ([Expr] -> [Statement]) -> [Expr] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Statement -> [Statement]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement -> [Statement])
-> ([Expr] -> Statement) -> [Expr] -> [Statement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Statement
JS.SRet (Expr -> Statement) -> ([Expr] -> Expr) -> [Expr] -> Statement
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [Expr] -> Expr
JS.EFunCall (Text -> Expr
JS.EVar Text
fun) ([Expr] -> Expr) -> m [Expr] -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Ann -> m Expr) -> [Expr Ann] -> m [Expr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr [Expr Ann]
args
        | Bool
otherwise ->
          Expr -> [Expr] -> Expr
JS.EFunCall (Text -> Expr
JS.EVar Text
fun) ([Expr] -> Expr) -> m [Expr] -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Ann -> m Expr) -> [Expr Ann] -> m [Expr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr [Expr Ann]
args

  EBlock Block Ann
block ->
    [Text] -> [Statement] -> Expr
JS.EFun [] ([Statement] -> Expr) -> m [Statement] -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Block Ann -> m [Statement]
forall (m :: * -> *). Translate m => Block Ann -> m [Statement]
translateBlock Block Ann
block

  ELet TermDef Ann
termdef Expr Ann
expr -> do
    Definition
def <- TermDef Ann -> m Definition
forall (m :: * -> *). Translate m => TermDef Ann -> m Definition
translateDef TermDef Ann
termdef
    Expr
expr' <- Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
expr
    Expr -> m Expr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expr -> m Expr) -> Expr -> m Expr
forall a b. (a -> b) -> a -> b
$ (Expr -> [Expr] -> Expr) -> [Expr] -> Expr -> Expr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Expr -> [Expr] -> Expr
JS.EFunCall [] (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ [Text] -> [Statement] -> Expr
JS.EFun []
      [ Definition -> Statement
JS.SDef Definition
def
      , Expr -> Statement
JS.SRet Expr
expr'
      ]

  EAnnotated Ann
_ Expr Ann
e ->
    Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
e

  e :: Expr Ann
e@EVariant{} ->
    String -> m Expr
forall a. HasCallStack => String -> a
error (String -> m Expr) -> String -> m Expr
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"COMPILER BUG: Unexpected naked EVariant not wrapped in EAnnotated - `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Expr Ann -> String
forall a. Show a => a -> String
show Expr Ann
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`."
      , String
"We need type annotation in order to know if the variant should take a payload as an argument."
      ]

translatePatterns :: Translate m => JS.Expr -> [(Pattern, Expr Ann)] -> m JS.Block
translatePatterns :: Expr -> [(Pattern, Expr Ann)] -> m [Statement]
translatePatterns Expr
outer = ((Pattern, Expr Ann) -> m Statement)
-> [(Pattern, Expr Ann)] -> m [Statement]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Pattern, Expr Ann) -> m Statement)
 -> [(Pattern, Expr Ann)] -> m [Statement])
-> ((Pattern, Expr Ann) -> m Statement)
-> [(Pattern, Expr Ann)]
-> m [Statement]
forall a b. (a -> b) -> a -> b
$ \(Pattern
pat, Expr Ann
body) -> do
  Expr
result' <- Expr Ann -> m Expr
forall (m :: * -> *). Translate m => Expr Ann -> m Expr
translateExpr Expr Ann
body
  PatResult [Expr]
conds [(Text, Expr)]
matches <- Expr -> Pattern -> m PatResult
forall (m :: * -> *). Translate m => Expr -> Pattern -> m PatResult
translatePattern Expr
outer Pattern
pat
  let ([Text]
matchersV, [Expr]
matchersE) = [(Text, Expr)] -> ([Text], [Expr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Text, Expr)]
matches
  Statement -> m Statement
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement -> m Statement) -> Statement -> m Statement
forall a b. (a -> b) -> a -> b
$ Expr -> [Statement] -> Statement
JS.SIf ([Expr] -> Expr
JS.EAnd [Expr]
conds)
    [ Expr -> Statement
JS.SRet (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ Expr -> [Expr] -> Expr
JS.EFunCall
      ( [Text] -> [Statement] -> Expr
JS.EFun [Text]
matchersV [ Expr -> Statement
JS.SRet Expr
result' ] )
      [Expr]
matchersE
    ]

{-

We want to translate ~pat -> result~ to something that looks like this:

if (<conditions>) {
    return (function(<matchersV>) { return result })(<matchersE>);
}

-}

data PatResult
  = PatResult
    { PatResult -> [Expr]
conditions :: [JS.Expr]
    , PatResult -> [(Text, Expr)]
matchers :: [(Var, JS.Expr)]
    }

instance Semigroup PatResult where
  <> :: PatResult -> PatResult -> PatResult
(<>) (PatResult [Expr]
c1 [(Text, Expr)]
m1) (PatResult [Expr]
c2 [(Text, Expr)]
m2) =
    [Expr] -> [(Text, Expr)] -> PatResult
PatResult ([Expr]
c1 [Expr] -> [Expr] -> [Expr]
forall a. Semigroup a => a -> a -> a
<> [Expr]
c2) ([(Text, Expr)]
m1 [(Text, Expr)] -> [(Text, Expr)] -> [(Text, Expr)]
forall a. Semigroup a => a -> a -> a
<> [(Text, Expr)]
m2)
instance Monoid PatResult where
  mempty :: PatResult
mempty = [Expr] -> [(Text, Expr)] -> PatResult
PatResult [] []

translatePattern :: Translate m => JS.Expr -> Pattern -> m PatResult
translatePattern :: Expr -> Pattern -> m PatResult
translatePattern Expr
expr = \case
  Pattern
PWildcard ->
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatResult -> m PatResult) -> PatResult -> m PatResult
forall a b. (a -> b) -> a -> b
$ PatResult :: [Expr] -> [(Text, Expr)] -> PatResult
PatResult
      { conditions :: [Expr]
conditions = [Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Bool -> Lit
JS.LBool Bool
True]
      , matchers :: [(Text, Expr)]
matchers = []
      }

  PVar Text
v ->
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatResult -> m PatResult) -> PatResult -> m PatResult
forall a b. (a -> b) -> a -> b
$ PatResult :: [Expr] -> [(Text, Expr)] -> PatResult
PatResult
      { conditions :: [Expr]
conditions = [Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Bool -> Lit
JS.LBool Bool
True]
      , matchers :: [(Text, Expr)]
matchers = [(Text
v, Expr
expr)]
      }

  PLit Lit
lit ->
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatResult -> m PatResult) -> PatResult -> m PatResult
forall a b. (a -> b) -> a -> b
$ PatResult :: [Expr] -> [(Text, Expr)] -> PatResult
PatResult
      { conditions :: [Expr]
conditions = [Expr -> Expr -> Expr
JS.EEquals (Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Lit -> Lit
translateLit Lit
lit) Expr
expr]
      , matchers :: [(Text, Expr)]
matchers = []
      }

  PVariant (Variant Text
"True" Maybe Pattern
Nothing) ->
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatResult -> m PatResult) -> PatResult -> m PatResult
forall a b. (a -> b) -> a -> b
$ PatResult :: [Expr] -> [(Text, Expr)] -> PatResult
PatResult
      { conditions :: [Expr]
conditions = [ Expr
expr ]
      , matchers :: [(Text, Expr)]
matchers = []
      }

  PVariant (Variant Text
"False" Maybe Pattern
Nothing) ->
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatResult -> m PatResult) -> PatResult -> m PatResult
forall a b. (a -> b) -> a -> b
$ PatResult :: [Expr] -> [(Text, Expr)] -> PatResult
PatResult
      { conditions :: [Expr]
conditions = [ Expr -> Expr
JS.ENot Expr
expr ]
      , matchers :: [(Text, Expr)]
matchers = []
      }

  PVariant (Variant Text
tag Maybe Pattern
mpat) -> do
    Maybe PatResult
pat' <- (Pattern -> m PatResult) -> Maybe Pattern -> m (Maybe PatResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Expr -> Pattern -> m PatResult
forall (m :: * -> *). Translate m => Expr -> Pattern -> m PatResult
translatePattern (Expr -> Text -> Expr
JS.ERecordAccess Expr
expr Text
"_field")) Maybe Pattern
mpat
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatResult -> m PatResult) -> PatResult -> m PatResult
forall a b. (a -> b) -> a -> b
$ PatResult :: [Expr] -> [(Text, Expr)] -> PatResult
PatResult
      { conditions :: [Expr]
conditions =
        ( Expr -> Expr -> Expr
JS.EEquals
          (Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Lit
JS.LString Text
tag)
          (Expr -> Text -> Expr
JS.ERecordAccess Expr
expr Text
"_constr")
        ) Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: [Expr] -> (PatResult -> [Expr]) -> Maybe PatResult -> [Expr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] PatResult -> [Expr]
conditions Maybe PatResult
pat'
      , matchers :: [(Text, Expr)]
matchers = [(Text, Expr)]
-> (PatResult -> [(Text, Expr)])
-> Maybe PatResult
-> [(Text, Expr)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] PatResult -> [(Text, Expr)]
matchers Maybe PatResult
pat'
      }

  POpenVariant (Variant Text
tag Pattern
pat) -> do
    PatResult
pat' <- Expr -> Pattern -> m PatResult
forall (m :: * -> *). Translate m => Expr -> Pattern -> m PatResult
translatePattern (Expr -> Text -> Expr
JS.ERecordAccess Expr
expr Text
"_field") Pattern
pat
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PatResult -> m PatResult) -> PatResult -> m PatResult
forall a b. (a -> b) -> a -> b
$ PatResult :: [Expr] -> [(Text, Expr)] -> PatResult
PatResult
      { conditions :: [Expr]
conditions =
        ( Expr -> Expr -> Expr
JS.EEquals
          (Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Lit
JS.LString Text
tag)
          (Expr -> Text -> Expr
JS.ERecordAccess Expr
expr Text
"_constr")
        ) Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: PatResult -> [Expr]
conditions PatResult
pat'
      , matchers :: [(Text, Expr)]
matchers = PatResult -> [(Text, Expr)]
matchers PatResult
pat'
      }

  PRecord (Record Pattern -> [(Text, Pattern)]
forall k a. Map k a -> [(k, a)]
M.toList -> [(Text, Pattern)]
fields) -> do
    ([PatResult] -> PatResult) -> m [PatResult] -> m PatResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PatResult] -> PatResult
forall a. Monoid a => [a] -> a
mconcat (m [PatResult] -> m PatResult) -> m [PatResult] -> m PatResult
forall a b. (a -> b) -> a -> b
$ [(Text, Pattern)]
-> ((Text, Pattern) -> m PatResult) -> m [PatResult]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Text, Pattern)]
fields (((Text, Pattern) -> m PatResult) -> m [PatResult])
-> ((Text, Pattern) -> m PatResult) -> m [PatResult]
forall a b. (a -> b) -> a -> b
$ \(Text
field, Pattern
pat) ->
      Expr -> Pattern -> m PatResult
forall (m :: * -> *). Translate m => Expr -> Pattern -> m PatResult
translatePattern (Expr -> Text -> Expr
JS.ERecordAccess Expr
expr Text
field) Pattern
pat

translateLit :: Lit -> JS.Lit
translateLit :: Lit -> Lit
translateLit = \case
  LInt TranState
i -> TranState -> Lit
JS.LInt TranState
i
  LFloat Float
f -> Float -> Lit
JS.LFloat Float
f
  LString Text
s -> Text -> Lit
JS.LString Text
s