-- 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 :: Int -> Q [Dec]
genFromLorentzFunN n :: Int
n = do
  [[Dec]]
fsArgs <- (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> Bool -> Q [Dec]
`fromLorentzFunN` Bool
True ) [1..Int
n]
  [[Dec]]
fsVoid <- (Int -> Q [Dec]) -> [Int] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> Bool -> Q [Dec]
`fromLorentzFunN` Bool
False) [1..Int
n]
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]]
fsArgs [[Dec]] -> [[Dec]] -> [[Dec]]
forall a. [a] -> [a] -> [a]
++ [[Dec]]
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 :: Int -> Bool -> Q [Dec]
fromLorentzFunN n :: Int
n hasRet :: Bool
hasRet
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "fromLorentzFunN requires a positive number of arguments"
  | Bool
otherwise = do
    -- Names
    Name
lz  <- String -> Q Name
newName "lz"
    [Name]
exs <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "ex"
    [Name]
as  <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "a"
    Name
st  <- String -> Q Name
newName "s"
    Name
ret <- String -> Q Name
newName "ret"
    let
      -- Parameters
      args :: [PatQ]
args = (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Name -> PatQ
varP (Name
lz Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
exs)
      -- Expressions
      exCompile :: [ExpQ]
exCompile = (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (\x :: Name
x -> [| compileToExpr $(varE x) |]) [Name]
exs
      compile :: Element [ExpQ]
compile = (Element [ExpQ] -> Element [ExpQ] -> Element [ExpQ])
-> [ExpQ] -> Element [ExpQ]
forall t.
Container t =>
(Element t -> Element t -> Element t) -> t -> Element t
foldl1 (\l :: Element [ExpQ]
l r :: Element [ExpQ]
r -> [| $r S.>> $l |]) [ExpQ]
exCompile
      updateMd :: ExpQ
updateMd = if Bool
hasRet then [| pushNoRefMd |] else [| id |]
      clear :: ExpQ
clear = if Bool
hasRet then [| L.drop |] else [| L.nop |]
      fun :: ExpQ
fun = Name -> ExpQ
varE Name
lz
      execute :: ExpQ
execute = [| S.IndigoState $ \md ->
        let cdc = gcCode $ runIndigoState $compile md in
        S.GenCode () ($updateMd md) (cdc # $fun) $clear |]
      body :: ExpQ
body = if Bool
hasRet
        then [| $execute S.>> O.makeTopVar |]
        else [| $execute |]
      -- Types
      asType :: [TypeQ]
asType = (Name -> TypeQ) -> [Name] -> [TypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Name -> TypeQ
varT [Name]
as
      exTypes :: [TypeQ]
exTypes = (Name -> TypeQ) -> [Name] -> [TypeQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Name -> TypeQ
varT [Name]
exs
      stType :: TypeQ
stType = Name -> TypeQ
varT Name
st
      retType :: TypeQ
retType = Name -> TypeQ
varT Name
ret

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

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

      fullType :: TypeQ
fullType = (Element [TypeQ] -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
foldr (TypeQ -> TypeQ -> TypeQ
appT (TypeQ -> TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeQ -> TypeQ -> TypeQ
appT TypeQ
arrowT) TypeQ
indigoType (TypeQ
lzType TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: [TypeQ]
exTypes)
      constraints :: CxtQ
constraints = [TypeQ] -> CxtQ
cxt ([TypeQ] -> CxtQ) -> ([TypeQ] -> [TypeQ]) -> [TypeQ] -> CxtQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
hasRet then ([t| KnownValue $retType |] TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
:) else [TypeQ] -> [TypeQ]
forall a. a -> a
id) ([TypeQ] -> CxtQ) -> [TypeQ] -> CxtQ
forall a b. (a -> b) -> a -> b
$
        (TypeQ -> TypeQ -> TypeQ) -> [TypeQ] -> [TypeQ] -> [TypeQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ex :: TypeQ
ex a :: TypeQ
a -> [t| IsExpr $ex $a |]) [TypeQ]
exTypes [TypeQ]
asType
    -- Definitions
    Dec
signature <- Name -> TypeQ -> DecQ
sigD Name
name (TypeQ -> DecQ) -> TypeQ -> DecQ
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT [] CxtQ
constraints TypeQ
fullType
    Dec
definition <- Name -> [ClauseQ] -> DecQ
funD Name
name [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
args (ExpQ -> BodyQ
normalB ExpQ
body) []]
    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
signature, Dec
definition]
  where
    name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ "fromLorentzFun" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
hasRet then "" else "Void")