{-# LANGUAGE NoRebindableSyntax #-}
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
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)
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
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
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)
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 |]
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
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")