{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

module Translate where

import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Traversable
import qualified JS.Ast as JS
import PatternMatching
import Wave.Ast
import Wave.Builtins hiding (builtins)
import Wave.Common

-- translate wave's AST to a subset of JS'AST
type TransState = Int

type TransReader = Builtins

type Translate a = (MonadState TransState a, MonadReader Builtins a)

translate :: (a -> StateT TransState (Reader Builtins) b) -> Builtins -> a -> b
translate :: (a -> StateT TransState (Reader Builtins) b) -> Builtins -> a -> b
translate a -> StateT TransState (Reader Builtins) b
tran Builtins
builtins a
ast =
  let s :: StateT TransState (Reader Builtins) b
s = a -> StateT TransState (Reader Builtins) b
tran a
ast
      r :: Reader Builtins b
r = StateT TransState (Reader Builtins) b
-> TransState -> Reader Builtins b
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT TransState (Reader Builtins) b
s TransState
0
      b :: b
b = Reader Builtins b -> Builtins -> b
forall r a. Reader r a -> r -> a
runReader Reader Builtins b
r Builtins
builtins
   in b
b

genVar :: Translate m => T.Text -> m Var
genVar :: Text -> m Text
genVar Text
var = do
  TransState
n <- m TransState
forall s (m :: * -> *). MonadState s m => m s
get
  (TransState -> TransState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (TransState -> TransState -> TransState
forall a. Num a => a -> a -> a
+ TransState
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
var 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 (TransState -> String
forall a. Show a => a -> String
show TransState
n))

--

translateFile :: Translate m => File () -> m JS.File
translateFile :: File () -> m File
translateFile (File [Definition ()]
defs) = do
  [Definition]
defs' <- (TermDef () -> m Definition) -> [TermDef ()] -> m [Definition]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TermDef () -> m Definition
forall (m :: * -> *). Translate m => TermDef () -> m Definition
translateDef [TermDef ()]
termDefs
  File -> m File
forall (f :: * -> *) a. Applicative f => a -> f a
pure (File -> m File) -> File -> m File
forall a b. (a -> b) -> a -> b
$ [Statement] -> File
JS.File ([Statement] -> File) -> [Statement] -> File
forall a b. (a -> b) -> a -> b
$ (Definition -> Statement) -> [Definition] -> [Statement]
forall a b. (a -> b) -> [a] -> [b]
map Definition -> Statement
JS.SDef [Definition]
defs' [Statement] -> [Statement] -> [Statement]
forall a. [a] -> [a] -> [a]
++ [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") []] -- fix this
  where
    termDefs :: [TermDef ()]
termDefs = [TermDef ()
d | (TermDef TermDef ()
d) <- [Definition ()]
defs] -- datatype defs are not translated

translateDef :: Translate m => TermDef () -> m JS.Definition
translateDef :: TermDef () -> m Definition
translateDef = \case
  Variable Text
var Expr ()
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 () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Expr ()
expr
  Function Text
var [Text]
args Sub ()
body -> Text -> [Text] -> [Statement] -> Definition
JS.Function Text
var [Text]
args ([Statement] -> Definition) -> m [Statement] -> m Definition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sub () -> m [Statement]
forall (m :: * -> *). Translate m => Sub () -> m [Statement]
translateSub Sub ()
body

translateExpr :: Translate m => Expr () -> m JS.Expr
translateExpr :: Expr () -> m Expr
translateExpr = \case
  EAnnotated ()
_ Expr ()
e -> Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Expr ()
e
  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 -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Lit -> Lit
translateLit Lit
lit
  EVar Text
var -> do
    Maybe Builtin
builtinOp <- (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
builtinOp 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 {Impl
bImpl :: Builtin -> Impl
bImpl :: Impl
bImpl} ->
        case Impl
bImpl of
          Fun Text
f -> 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
f
          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
"a", Text
"b"]
                [Expr -> Statement
JS.SRet (Expr -> Statement) -> Expr -> Statement
forall a b. (a -> b) -> a -> b
$ Text -> Expr -> Expr -> Expr
JS.EBinOp Text
op (Text -> Expr
JS.EVar Text
"a") (Text -> Expr
JS.EVar Text
"b")]
  EFun [Text]
args Sub ()
body -> [Text] -> [Statement] -> Expr
JS.EFun [Text]
args ([Statement] -> Expr) -> m [Statement] -> m Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sub () -> m [Statement]
forall (m :: * -> *). Translate m => Sub () -> m [Statement]
translateSub Sub ()
body
  EFunCall Expr ()
fun [Expr ()]
args -> do
    Expr
fun' <- Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Expr ()
fun
    [Expr]
args' <- (Expr () -> m Expr) -> [Expr ()] -> m [Expr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr [Expr ()]
args
    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]
args'
  ERecord Record (Expr ())
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 () -> m Expr) -> Record (Expr ()) -> m (Record Expr)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Record (Expr ())
record
  EFfi Text
fun [Expr ()]
args -> 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 () -> m Expr) -> [Expr ()] -> m [Expr]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr [Expr ()]
args
  EVariant (Variant Text
"True" 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
$ Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Bool -> Lit
JS.LBool Bool
True
  EVariant (Variant Text
"False" 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
$ Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Bool -> Lit
JS.LBool Bool
False
  EVariant (Variant Text
kind Expr ()
value) -> do
    Expr
value' <- Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Expr ()
value
    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
"_kind", Lit -> Expr
JS.ELit (Lit -> Expr) -> Lit -> Expr
forall a b. (a -> b) -> a -> b
$ Text -> Lit
JS.LString Text
kind),
            (Text
"_value", Expr
value')
          ]
  ECase Expr ()
expr [(Pattern, Expr ())]
patterns -> do
    Expr
expr' <- Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Expr ()
expr
    Text
var <- Text -> m Text
forall (m :: * -> *). Translate m => Text -> m Text
genVar Text
"case"
    [Statement]
patterns' <- Expr -> [(Pattern, Expr ())] -> m [Statement]
forall (m :: * -> *).
Translate m =>
Expr -> [(Pattern, Expr ())] -> m [Statement]
translatePatterns (Text -> Expr
JS.EVar Text
var) [(Pattern, Expr ())]
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']
  ERecordAccess Expr ()
expr Text
label -> do
    Expr
expr' <- Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Expr ()
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 -> Text -> Expr
JS.ERecordAccess Expr
expr' Text
label

translatePatterns :: Translate m => JS.Expr -> [(Pattern, Expr ())] -> m JS.Sub
translatePatterns :: Expr -> [(Pattern, Expr ())] -> m [Statement]
translatePatterns Expr
var = ((Pattern, Expr ()) -> m Statement)
-> [(Pattern, Expr ())] -> m [Statement]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (((Pattern, Expr ()) -> m Statement)
 -> [(Pattern, Expr ())] -> m [Statement])
-> ((Pattern, Expr ()) -> m Statement)
-> [(Pattern, Expr ())]
-> m [Statement]
forall a b. (a -> b) -> a -> b
$ \(Pattern
pat, Expr ()
expr) -> do
  Expr
result' <- Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Expr ()
expr
  PatResult [Expr]
conds [(Text, Expr)]
matchers' <- Expr -> Pattern -> m PatResult
forall (m :: * -> *). Translate m => Expr -> Pattern -> m PatResult
translatePattern Expr
var Pattern
pat
  let ([Text]
matchersV, [Expr]
matchersE) = [(Text, Expr)] -> ([Text], [Expr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Text, Expr)]
matchers'
  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
      ]

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 :: [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], -- always match
          matchers :: [(Text, Expr)]
matchers = [] -- but don't bind anything
        }
  PVar Text
var ->
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      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], -- always match
          matchers :: [(Text, Expr)]
matchers = [(Text
var, Expr
expr)] -- and bind the var to the expression
        }
  PLit Lit
lit ->
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      PatResult :: [Expr] -> [(Text, Expr)] -> PatResult
PatResult
        { conditions :: [Expr]
conditions = [Expr -> Expr -> Expr
JS.EEqual (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 = []
        }
  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
  PVariant (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
"_value") Pattern
pat
    PatResult -> m PatResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      PatResult :: [Expr] -> [(Text, Expr)] -> PatResult
PatResult
        { conditions :: [Expr]
conditions =
            Expr -> Expr -> Expr
JS.EEqual
              (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
"_kind") Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
:
            PatResult -> [Expr]
conditions PatResult
pat',
          matchers :: [(Text, Expr)]
matchers = PatResult -> [(Text, Expr)]
matchers PatResult
pat'
        }

translateSub :: Translate m => Sub () -> m JS.Sub
translateSub :: Sub () -> m [Statement]
translateSub Sub ()
stmts = case Sub () -> Sub ()
forall a. [a] -> [a]
reverse Sub ()
stmts of
  [] -> [Statement] -> m [Statement]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  SExpr Expr ()
expr : Sub ()
rest -> do
    Statement
ret <- Expr -> Statement
JS.SRet (Expr -> Statement) -> m Expr -> m Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Expr ()
expr
    [Statement]
rest' <- Sub () -> m [Statement]
translateSub' Sub ()
rest
    [Statement] -> m [Statement]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Statement] -> m [Statement]) -> [Statement] -> m [Statement]
forall a b. (a -> b) -> a -> b
$ [Statement] -> [Statement]
forall a. [a] -> [a]
reverse (Statement
ret Statement -> [Statement] -> [Statement]
forall a. a -> [a] -> [a]
: [Statement]
rest')
  Sub ()
_ -> Sub () -> m [Statement]
translateSub' Sub ()
stmts
  where
    translateSub' :: Sub () -> m [Statement]
translateSub' = (Statement () -> m Statement) -> Sub () -> m [Statement]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Statement () -> m Statement
forall (m :: * -> *). Translate m => Statement () -> m Statement
translateStatement

translateStatement :: Translate m => Statement () -> m JS.Statement
translateStatement :: Statement () -> m Statement
translateStatement = \case
  SExpr Expr ()
expr -> Expr -> Statement
JS.SExpr (Expr -> Statement) -> m Expr -> m Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr () -> m Expr
forall (m :: * -> *). Translate m => Expr () -> m Expr
translateExpr Expr ()
expr
  SDef TermDef ()
def -> Definition -> Statement
JS.SDef (Definition -> Statement) -> m Definition -> m Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermDef () -> m Definition
forall (m :: * -> *). Translate m => TermDef () -> m Definition
translateDef TermDef ()
def

translateLit :: Lit -> JS.Lit
translateLit :: Lit -> Lit
translateLit = \case
  LInt TransState
int -> TransState -> Lit
JS.LInt TransState
int
  LFloat Float
float -> Float -> Lit
JS.LFloat Float
float
  LString Text
str -> Text -> Lit
JS.LString Text
str