FromLorentz.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# LANGUAGE NoRebindableSyntax #-}

-- | Generation of functions that convert Lorentz code to Indigo

module Indigo.FromLorentz
  ( genFromLorentzFunN
  , fromLorentzFunN
  ) where

import Control.Monad hiding (replicateM)
import Language.Haskell.TH

import Indigo.Backend.Prelude
import Indigo.Internal.Expr (IsExpr)
import qualified Indigo.Internal.Object as O
import qualified Indigo.Internal.State as S
import Indigo.Lorentz (type (&), (:->), KnownValue)
import qualified Lorentz.Instr as L

-- | Generates all of the 'fromLorentzFunN' (both with and without return value)
-- from 1 to the given @n@
genFromLorentzFunN :: Int -> Q [Dec]
genFromLorentzFunN n = do
  fsArgs <- mapM (`fromLorentzFunN` True ) [1..n]
  fsVoid <- mapM (`fromLorentzFunN` False) [1..n]
  return $ concat (fsArgs ++ fsVoid)

-- | Generates a function that converts a Lorentz expression to an Indigo one.
--
-- The first parameter is the number of elements that the Lorentz code consumes
-- from the stack, as well as the number of Indigo 'IsExpr' values.
--
-- The second parameter is to establish if there is a return value or not,
-- as well as the name of the function.
--
-- Examples:
--
-- * @fromLorentzFunN 1 False@ produces:
--
-- @
-- fromLorentzFun1Void :: IsExpr ex a => a & s :-> s -> ex -> IndigoM s s ()
-- @
-- * @fromLorentzFunN 2 True@ produces:
--
-- @
-- fromLorentzFun2
--   :: (KnownValue ret, IsExpr ex1 a, IsExpr ex2 b)
--   => a & b & s :-> ret & s
--   -> ex1 -> ex2 -> IndigoM s (ret & s) (Var ret)
-- @
fromLorentzFunN :: Int -> Bool -> Q [Dec]
fromLorentzFunN n hasRet
  | n <= 0 = fail "fromLorentzFunN requires a positive number of arguments"
  | otherwise = do
    -- Names
    lz  <- newName "lz"
    exs <- replicateM n $ newName "ex"
    as  <- replicateM n $ newName "a"
    st  <- newName "s"
    ret <- newName "ret"
    let
      -- Parameters
      args = map varP (lz : exs)
      -- Expressions
      exCompile = map (\x -> [| compileToExpr $(varE x) |]) exs
      compile = foldl1 (\l r -> [| $r S.>> $l |]) exCompile
      updateMd = if hasRet then [| pushNoRefMd |] else [| id |]
      clear = if hasRet then [| L.drop |] else [| L.nop |]
      fun = varE lz
      execute = [| S.IndigoState $ \md ->
        let cdc = gcCode $ runIndigoState $compile md in
        S.GenCode () ($updateMd md) (cdc # $fun) $clear |]
      body = if hasRet
        then [| $execute S.>> O.makeTopVar |]
        else [| $execute |]
      -- Types
      asType = map varT as
      exTypes = map varT exs
      stType = varT st
      retType = varT ret

      inpType = foldr1 (\a c -> [t| ($a & $c) |] ) (asType ++ [stType])
      outType = if hasRet then [t| $retType & $stType |] else stType
      lzType = [t| $inpType :-> $outType |]

      indigoRetType = if hasRet then [t| O.Var $retType |] else [t| () |]
      indigoType = [t| S.IndigoState $stType $outType $indigoRetType |]

      fullType = foldr (appT . appT arrowT) indigoType (lzType : exTypes)
      constraints = cxt . (if hasRet then ([t| KnownValue $retType |] :) else id) $
        zipWith (\ex a -> [t| IsExpr $ex $a |]) exTypes asType
    -- Definitions
    signature <- sigD name $ forallT [] constraints fullType
    definition <- funD name [clause args (normalB body) []]
    return [signature, definition]
  where
    name = mkName $ "fromLorentzFun" ++ show n ++ (if hasRet then "" else "Void")