-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>
--
-- SPDX-License-Identifier: GPL-3.0-only

module Language.QBE.Simulator.Default.Generator (generateOperators) where

import Language.Haskell.TH

data ValueCons
  = VWord
  | VLong
  | VSingle
  | VDouble
  deriving (Int -> ValueCons -> ShowS
[ValueCons] -> ShowS
ValueCons -> String
(Int -> ValueCons -> ShowS)
-> (ValueCons -> String)
-> ([ValueCons] -> ShowS)
-> Show ValueCons
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueCons -> ShowS
showsPrec :: Int -> ValueCons -> ShowS
$cshow :: ValueCons -> String
show :: ValueCons -> String
$cshowList :: [ValueCons] -> ShowS
showList :: [ValueCons] -> ShowS
Show)

toSigned :: ValueCons -> Maybe String
toSigned :: ValueCons -> Maybe String
toSigned ValueCons
VWord = String -> Maybe String
forall a. a -> Maybe a
Just String
"Int32"
toSigned ValueCons
VLong = String -> Maybe String
forall a. a -> Maybe a
Just String
"Int64"
toSigned ValueCons
VSingle = Maybe String
forall a. Maybe a
Nothing
toSigned ValueCons
VDouble = Maybe String
forall a. Maybe a
Nothing

toSignedExp :: ValueCons -> Exp -> Exp
toSignedExp :: ValueCons -> Exp -> Exp
toSignedExp ValueCons
vCons Exp
expr =
  case ValueCons -> Maybe String
toSigned ValueCons
vCons of
    Maybe String
Nothing -> Exp
expr
    Just String
st ->
      let cast :: Exp
cast = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fromIntegral") Exp
expr
       in Exp -> Type -> Exp
SigE Exp
cast (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
st)

------------------------------------------------------------------------

thBinaryFunc :: Exp -> Exp -> Exp -> Exp
thBinaryFunc :: Exp -> Exp -> Exp -> Exp
thBinaryFunc Exp
func Exp
lhs = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE Exp
func Exp
lhs)

thBinaryOp :: Exp -> Exp -> Exp -> Exp
thBinaryOp :: Exp -> Exp -> Exp -> Exp
thBinaryOp Exp
op = Exp -> Exp -> Exp -> Exp
thBinaryFunc (Exp -> Exp
ParensE Exp
op)

------------------------------------------------------------------------

-- Takes an lhs and rhs value and transform it to some 'Exp'.
type Transformer = ValueCons -> Exp -> Exp -> Exp

applyFunc :: Exp -> ValueCons -> Exp -> Exp -> Exp
applyFunc :: Exp -> ValueCons -> Exp -> Exp -> Exp
applyFunc Exp
func ValueCons
vCon Exp
lhs Exp
rhs =
  Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (ValueCons -> String
forall a. Show a => a -> String
show ValueCons
vCon)) (Exp -> Exp -> Exp -> Exp
thBinaryFunc Exp
func Exp
lhs Exp
rhs)

applyOp :: Name -> ValueCons -> Exp -> Exp -> Exp
applyOp :: Name -> ValueCons -> Exp -> Exp -> Exp
applyOp Name
opName =
  Exp -> ValueCons -> Exp -> Exp -> Exp
applyFunc (Exp -> Exp
ParensE (Name -> Exp
VarE Name
opName))

applySignedOp :: Name -> ValueCons -> Exp -> Exp -> Exp
applySignedOp :: Name -> ValueCons -> Exp -> Exp -> Exp
applySignedOp Name
opName ValueCons
vCon Exp
lhs Exp
rhs =
  let lhs' :: Exp
lhs' = ValueCons -> Exp -> Exp
toSignedExp ValueCons
vCon Exp
lhs
      rhs' :: Exp
rhs' = ValueCons -> Exp -> Exp
toSignedExp ValueCons
vCon Exp
rhs
      cast :: Exp -> Exp
cast = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"fromIntegral")
   in -- TODO: Code duplication with applyFunc
      Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (ValueCons -> String
forall a. Show a => a -> String
show ValueCons
vCon)) (Exp -> Exp
cast (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
thBinaryFunc (Name -> Exp
VarE Name
opName) Exp
lhs' Exp
rhs')

applyBoolOp :: Name -> ValueCons -> Exp -> Exp -> Exp
applyBoolOp :: Name -> ValueCons -> Exp -> Exp -> Exp
applyBoolOp Name
opName ValueCons
_vCons Exp
lhs Exp
rhs =
  let res :: Exp
res = Exp -> Exp -> Exp -> Exp
thBinaryOp (Name -> Exp
VarE Name
opName) Exp
lhs Exp
rhs
      toL :: Exp -> Exp
toL = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"E.fromLit") (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"QBE.Base") (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"QBE.Long")))
   in Exp -> Exp
toL (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
CondE Exp
res (Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
1) (Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL Integer
0)

applySignedBoolOp :: Name -> ValueCons -> Exp -> Exp -> Exp
applySignedBoolOp :: Name -> ValueCons -> Exp -> Exp -> Exp
applySignedBoolOp Name
opName ValueCons
vCons Exp
lhs Exp
rhs =
  Name -> ValueCons -> Exp -> Exp -> Exp
applyBoolOp Name
opName ValueCons
vCons (ValueCons -> Exp -> Exp
toSignedExp ValueCons
vCons Exp
lhs) (ValueCons -> Exp -> Exp
toSignedExp ValueCons
vCons Exp
rhs)

------------------------------------------------------------------------

operators :: [(Name, Transformer)]
operators :: [(Name, ValueCons -> Exp -> Exp -> Exp)]
operators =
  [ (String -> Name
mkName String
"add'", Name -> ValueCons -> Exp -> Exp -> Exp
applyOp (String -> Name
mkName String
"+")),
    (String -> Name
mkName String
"sub'", Name -> ValueCons -> Exp -> Exp -> Exp
applyOp (String -> Name
mkName String
"-")),
    (String -> Name
mkName String
"mul'", Name -> ValueCons -> Exp -> Exp -> Exp
applyOp (String -> Name
mkName String
"*")),
    (String -> Name
mkName String
"eq'", Name -> ValueCons -> Exp -> Exp -> Exp
applyBoolOp (String -> Name
mkName String
"==")),
    (String -> Name
mkName String
"ne'", Name -> ValueCons -> Exp -> Exp -> Exp
applyBoolOp (String -> Name
mkName String
"/=")),
    (String -> Name
mkName String
"sle'", Name -> ValueCons -> Exp -> Exp -> Exp
applySignedBoolOp (String -> Name
mkName String
"<=")),
    (String -> Name
mkName String
"slt'", Name -> ValueCons -> Exp -> Exp -> Exp
applySignedBoolOp (String -> Name
mkName String
"<")),
    (String -> Name
mkName String
"sge'", Name -> ValueCons -> Exp -> Exp -> Exp
applySignedBoolOp (String -> Name
mkName String
">=")),
    (String -> Name
mkName String
"sgt'", Name -> ValueCons -> Exp -> Exp -> Exp
applySignedBoolOp (String -> Name
mkName String
">")),
    (String -> Name
mkName String
"ule'", Name -> ValueCons -> Exp -> Exp -> Exp
applyBoolOp (String -> Name
mkName String
"<=")),
    (String -> Name
mkName String
"ult'", Name -> ValueCons -> Exp -> Exp -> Exp
applyBoolOp (String -> Name
mkName String
"<")),
    (String -> Name
mkName String
"uge'", Name -> ValueCons -> Exp -> Exp -> Exp
applyBoolOp (String -> Name
mkName String
">=")),
    (String -> Name
mkName String
"ugt'", Name -> ValueCons -> Exp -> Exp -> Exp
applyBoolOp (String -> Name
mkName String
">"))
  ]

decOperators :: [(Name, Transformer)]
decOperators :: [(Name, ValueCons -> Exp -> Exp -> Exp)]
decOperators =
  [ (String -> Name
mkName String
"srem'", Name -> ValueCons -> Exp -> Exp -> Exp
applySignedOp (String -> Name
mkName String
"rem")),
    (String -> Name
mkName String
"urem'", Name -> ValueCons -> Exp -> Exp -> Exp
applyOp (String -> Name
mkName String
"rem")),
    (String -> Name
mkName String
"udiv'", Name -> ValueCons -> Exp -> Exp -> Exp
applyOp (String -> Name
mkName String
"quot")),
    (String -> Name
mkName String
"or'", Name -> ValueCons -> Exp -> Exp -> Exp
applyOp (String -> Name
mkName String
".|.")),
    (String -> Name
mkName String
"xor'", Name -> ValueCons -> Exp -> Exp -> Exp
applyOp (String -> Name
mkName String
"Data.Bits.xor")),
    (String -> Name
mkName String
"and'", Name -> ValueCons -> Exp -> Exp -> Exp
applyOp (String -> Name
mkName String
".&."))
  ]

------------------------------------------------------------------------

decCons :: [ValueCons]
decCons :: [ValueCons]
decCons = [ValueCons
VWord, ValueCons
VLong]

cons :: [ValueCons]
cons :: [ValueCons]
cons = [ValueCons]
decCons [ValueCons] -> [ValueCons] -> [ValueCons]
forall a. [a] -> [a] -> [a]
++ [ValueCons
VSingle, ValueCons
VDouble]

makeClause :: Transformer -> ValueCons -> Q Clause
makeClause :: (ValueCons -> Exp -> Exp -> Exp) -> ValueCons -> Q Clause
makeClause ValueCons -> Exp -> Exp -> Exp
trans ValueCons
vCon = do
  Name
lhs <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"lhs"
  Name
rhs <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"rhs"

  let res :: Exp
res = ValueCons -> Exp -> Exp -> Exp
trans ValueCons
vCon (Name -> Exp
VarE Name
lhs) (Name -> Exp
VarE Name
rhs)
  let body :: Exp
body = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (String -> Name
mkName String
"Just")) Exp
res

  let con :: Name
con = String -> Name
mkName (ValueCons -> String
forall a. Show a => a -> String
show ValueCons
vCon)
  Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$
    [Pat] -> Body -> [Dec] -> Clause
Clause
      [ Name -> [Type] -> [Pat] -> Pat
ConP Name
con [] [Name -> Pat
VarP Name
lhs],
        Name -> [Type] -> [Pat] -> Pat
ConP Name
con [] [Name -> Pat
VarP Name
rhs]
      ]
      (Exp -> Body
NormalB Exp
body)
      []

typingErrorClause :: Clause
typingErrorClause :: Clause
typingErrorClause =
  [Pat] -> Body -> [Dec] -> Clause
Clause
    [Pat
WildP, Pat
WildP]
    (Exp -> Body
NormalB (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Nothing"))
    []

------------------------------------------------------------------------

genOp :: [ValueCons] -> (Name, Transformer) -> Q Dec
genOp :: [ValueCons] -> (Name, ValueCons -> Exp -> Exp -> Exp) -> Q Dec
genOp [ValueCons]
opLst (Name
name, ValueCons -> Exp -> Exp -> Exp
trans) = do
  [Clause]
valDefs <- (ValueCons -> Q Clause) -> [ValueCons] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((ValueCons -> Exp -> Exp -> Exp) -> ValueCons -> Q Clause
makeClause ValueCons -> Exp -> Exp -> Exp
trans) [ValueCons]
opLst
  Dec -> Q Dec
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD Name
name ([Clause]
valDefs [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause
typingErrorClause])

generateOperators :: Q [Dec]
generateOperators :: Q [Dec]
generateOperators = do
  [Dec]
o1 <- ((Name, ValueCons -> Exp -> Exp -> Exp) -> Q Dec)
-> [(Name, ValueCons -> Exp -> Exp -> Exp)] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([ValueCons] -> (Name, ValueCons -> Exp -> Exp -> Exp) -> Q Dec
genOp [ValueCons]
cons) [(Name, ValueCons -> Exp -> Exp -> Exp)]
operators
  [Dec]
o2 <- ((Name, ValueCons -> Exp -> Exp -> Exp) -> Q Dec)
-> [(Name, ValueCons -> Exp -> Exp -> Exp)] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([ValueCons] -> (Name, ValueCons -> Exp -> Exp -> Exp) -> Q Dec
genOp [ValueCons]
decCons) [(Name, ValueCons -> Exp -> Exp -> Exp)]
decOperators
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
o1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
o2