-- This module generates smart constructors for the LibRISCV expressions
-- language through template-haskell. These constructors are syntactic sugar
-- intended to ease usage of the expression language.
module LibRISCV.Effects.Expressions.Generator (generateImmediates) where

import Data.Char (toLower)
import Language.Haskell.TH

binOps :: [String]
binOps :: [String]
binOps =
    [ String
"Add"
    , String
"Sub"
    , String
"Eq"
    , String
"Slt"
    , String
"Sge"
    , String
"Ult"
    , String
"Uge"
    , String
"And"
    , String
"Or"
    , String
"Xor"
    , String
"LShl"
    , String
"LShr"
    , String
"AShr"
    , String
"Mul"
    , String
"UDiv"
    , String
"SDiv"
    , String
"URem"
    , String
"SRem"
    ]

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

foldcase :: String -> String
foldcase :: String -> String
foldcase = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

genImm :: String -> Q Dec
genImm :: String -> Q Dec
genImm String
operator = do
    let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
foldcase String
operator

    let consName :: Name
consName = String -> Name
mkName String
operator
    let immName :: Name
immName = String -> Name
mkName String
"FromImm"
    Name
rval <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"rval"
    Name
lval <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"lval"

    let body :: Exp
body =
            Exp -> Exp -> Exp
AppE
                (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
consName) (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
immName) (Name -> Exp
VarE Name
lval)))
                (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
immName) (Name -> Exp
VarE Name
rval))
    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 [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
lval, Name -> Pat
VarP Name
rval] (Exp -> Body
NormalB Exp
body) []]

genImmRval :: String -> Q Dec
genImmRval :: String -> Q Dec
genImmRval String
operator = do
    let name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
foldcase String
operator String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Imm"

    let onName :: Name
onName = String -> Name
mkName String
"on"
    let consName :: Name
consName = String -> Name
mkName String
operator
    let immName :: Name
immName = String -> Name
mkName String
"FromImm"

    let body :: Exp
body = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
onName) (Name -> Exp
ConE Name
consName)) (Name -> Exp
ConE Name
immName)
    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 [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
body) []]

generateImmediates :: Q [Dec]
generateImmediates :: Q [Dec]
generateImmediates = do
    [Dec]
l1 <- (String -> Q Dec) -> [String] -> 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 String -> Q Dec
genImmRval [String]
binOps
    [Dec]
l2 <- (String -> Q Dec) -> [String] -> 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 String -> Q Dec
genImm [String]
binOps
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
l1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
l2)