{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings, RecordWildCards, MultiWayIf, ViewPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Language.Asm.Inline.QQ
( asm
, asmTy

, substitute
, unroll
, unrolls
) where

import qualified Data.Map as M
import Control.Applicative(ZipList(..))
import Control.Monad.Combinators.Expr as CE
import Control.Monad.Except
import Control.Monad.State.Strict
import Data.Bifunctor
import Data.Char
import Data.Either.Combinators
import Data.Foldable
import Data.Functor
import Data.List
import Data.String
import Data.Void
import Foreign.Ptr
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as ML

import Language.Asm.Inline.AsmCode

instance AsmCode AsmQQType AsmQQCode where
  codeToString :: AsmQQType -> AsmQQCode -> String
codeToString AsmQQType
ty AsmQQCode
code = case AsmQQType -> AsmQQCode -> Either String AsmQQCode
substituteArgs AsmQQType
ty AsmQQCode
code of
                              Left String
e -> String -> String
forall a. HasCallStack => String -> a
error String
e
                              Right AsmQQCode
s -> AsmQQCode -> String
asmCode AsmQQCode
s
  toTypeQ :: AsmQQType -> Q Type
toTypeQ = AsmQQType -> Q Type
unreflectTy

asm :: QuasiQuoter
asm :: QuasiQuoter
asm = (String -> Q Exp) -> QuasiQuoter
expQQ String -> Q Exp
asmQE

asmQE :: String -> Q Exp
asmQE :: String -> Q Exp
asmQE String
p = [e| AsmQQCode p |]

newtype AsmQQCode = AsmQQCode { AsmQQCode -> String
asmCode :: String }

instance Semigroup AsmQQCode where
  AsmQQCode
c1 <> :: AsmQQCode -> AsmQQCode -> AsmQQCode
<> AsmQQCode
c2 = String -> AsmQQCode
AsmQQCode (String -> AsmQQCode) -> String -> AsmQQCode
forall a b. (a -> b) -> a -> b
$ AsmQQCode -> String
asmCode AsmQQCode
c1 String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AsmQQCode -> String
asmCode AsmQQCode
c2

instance Monoid AsmQQCode where
  mempty :: AsmQQCode
mempty = String -> AsmQQCode
AsmQQCode String
""


parseExpr :: MonadError String m => String -> String -> m (Int -> Int)
parseExpr :: String -> String -> m (Int -> Int)
parseExpr String
var String
inputStr = Either String (Int -> Int) -> m (Int -> Int)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String (Int -> Int) -> m (Int -> Int))
-> Either String (Int -> Int) -> m (Int -> Int)
forall a b. (a -> b) -> a -> b
$ (ParseErrorBundle String Void -> String)
-> Either (ParseErrorBundle String Void) (Int -> Int)
-> Either String (Int -> Int)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle String Void -> String
showParseError (Either (ParseErrorBundle String Void) (Int -> Int)
 -> Either String (Int -> Int))
-> Either (ParseErrorBundle String Void) (Int -> Int)
-> Either String (Int -> Int)
forall a b. (a -> b) -> a -> b
$ Parsec Void String (Int -> Int)
-> String
-> String
-> Either (ParseErrorBundle String Void) (Int -> Int)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void String (Int -> Int)
expr Parsec Void String (Int -> Int)
-> ParsecT Void String Identity ()
-> Parsec Void String (Int -> Int)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"" String
inputStr
  where
    expr :: Parsec Void String (Int -> Int)
expr = Parsec Void String (Int -> Int)
-> [[Operator (ParsecT Void String Identity) (Int -> Int)]]
-> Parsec Void String (Int -> Int)
forall (m :: * -> *) a.
MonadPlus m =>
m a -> [[Operator m a]] -> m a
makeExprParser Parsec Void String (Int -> Int)
term [[Operator (ParsecT Void String Identity) (Int -> Int)]]
forall t. [[Operator (ParsecT Void String Identity) (t -> Int)]]
table Parsec Void String (Int -> Int)
-> String -> Parsec Void String (Int -> Int)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"expr"
    term :: Parsec Void String (Int -> Int)
term = Parsec Void String (Int -> Int) -> Parsec Void String (Int -> Int)
forall a.
ParsecT Void String Identity a -> ParsecT Void String Identity a
parens Parsec Void String (Int -> Int)
expr
       Parsec Void String (Int -> Int)
-> Parsec Void String (Int -> Int)
-> Parsec Void String (Int -> Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void String (Int -> Int) -> Parsec Void String (Int -> Int)
forall a.
ParsecT Void String Identity a -> ParsecT Void String Identity a
lexeme (ParsecT Void String Identity ()
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
ML.signed ParsecT Void String Identity ()
lexSpace (Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"0x" ParsecT Void String Identity String
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
ML.hexadecimal ParsecT Void String Identity Int
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
ML.decimal) ParsecT Void String Identity Int
-> (Int -> Int -> Int) -> Parsec Void String (Int -> Int)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Int -> Int -> Int
forall a b. a -> b -> a
const)
       Parsec Void String (Int -> Int)
-> Parsec Void String (Int -> Int)
-> Parsec Void String (Int -> Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void String (Int -> Int) -> Parsec Void String (Int -> Int)
forall a.
ParsecT Void String Identity a -> ParsecT Void String Identity a
lexeme (Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
Tokens String
var ParsecT Void String Identity String
-> (Int -> Int) -> Parsec Void String (Int -> Int)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int -> Int
forall a. a -> a
id)
    table :: [[Operator (ParsecT Void String Identity) (t -> Int)]]
table = [ [ Tokens String
-> (Int -> Int -> Int)
-> Operator (ParsecT Void String Identity) (t -> Int)
forall t t.
Tokens String
-> (t -> t -> t)
-> Operator (ParsecT Void String Identity) (t -> t)
binary Tokens String
"*" Int -> Int -> Int
forall a. Num a => a -> a -> a
(*) ]
            , [ Tokens String
-> (Int -> Int -> Int)
-> Operator (ParsecT Void String Identity) (t -> Int)
forall t t.
Tokens String
-> (t -> t -> t)
-> Operator (ParsecT Void String Identity) (t -> t)
binary Tokens String
"+" Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
              , Tokens String
-> (Int -> Int -> Int)
-> Operator (ParsecT Void String Identity) (t -> Int)
forall t t.
Tokens String
-> (t -> t -> t)
-> Operator (ParsecT Void String Identity) (t -> t)
binary Tokens String
"-" (-)
              ]
            ]
    binary :: Tokens String
-> (t -> t -> t)
-> Operator (ParsecT Void String Identity) (t -> t)
binary Tokens String
name t -> t -> t
fun = ParsecT Void String Identity ((t -> t) -> (t -> t) -> t -> t)
-> Operator (ParsecT Void String Identity) (t -> t)
forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
CE.InfixL (ParsecT Void String Identity ((t -> t) -> (t -> t) -> t -> t)
 -> Operator (ParsecT Void String Identity) (t -> t))
-> ParsecT Void String Identity ((t -> t) -> (t -> t) -> t -> t)
-> Operator (ParsecT Void String Identity) (t -> t)
forall a b. (a -> b) -> a -> b
$ Tokens String -> ParsecT Void String Identity (Tokens String)
symbol Tokens String
name ParsecT Void String Identity (Tokens String)
-> ((t -> t) -> (t -> t) -> t -> t)
-> ParsecT Void String Identity ((t -> t) -> (t -> t) -> t -> t)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (\t -> t
l t -> t
r t
n -> t -> t
l t
n t -> t -> t
`fun` t -> t
r t
n)
    symbol :: Tokens String -> ParsecT Void String Identity (Tokens String)
symbol = ParsecT Void String Identity ()
-> Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
ML.symbol ParsecT Void String Identity ()
lexSpace
    parens :: ParsecT Void String Identity a -> ParsecT Void String Identity a
parens = ParsecT Void String Identity (Tokens String)
-> ParsecT Void String Identity (Tokens String)
-> ParsecT Void String Identity a
-> ParsecT Void String Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Tokens String -> ParsecT Void String Identity (Tokens String)
symbol Tokens String
"(") (Tokens String -> ParsecT Void String Identity (Tokens String)
symbol Tokens String
")")
    lexeme :: ParsecT Void String Identity a -> ParsecT Void String Identity a
lexeme = ParsecT Void String Identity ()
-> ParsecT Void String Identity a -> ParsecT Void String Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
ML.lexeme ParsecT Void String Identity ()
lexSpace
    lexSpace :: ParsecT Void String Identity ()
lexSpace = ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
ML.space ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 ParsecT Void String Identity ()
forall (f :: * -> *) a. Alternative f => f a
empty ParsecT Void String Identity ()
forall (f :: * -> *) a. Alternative f => f a
empty

unroll :: String -> [Int] -> AsmQQCode -> AsmQQCode
unroll :: String -> [Int] -> AsmQQCode -> AsmQQCode
unroll String
var [Int]
ints AsmQQCode
code = case (String -> ZipList String)
-> AsmQQCode -> Either String (ZipList AsmQQCode)
forall (f :: * -> *).
Applicative f =>
(String -> f String) -> AsmQQCode -> Either String (f AsmQQCode)
substitute String -> ZipList String
sub AsmQQCode
code of
                            Left String
err -> String -> AsmQQCode
forall a. HasCallStack => String -> a
error String
err
                            Right ZipList AsmQQCode
codes -> [AsmQQCode] -> AsmQQCode
forall a. Monoid a => [a] -> a
mconcat ([AsmQQCode] -> AsmQQCode) -> [AsmQQCode] -> AsmQQCode
forall a b. (a -> b) -> a -> b
$ ZipList AsmQQCode -> [AsmQQCode]
forall a. ZipList a -> [a]
getZipList ZipList AsmQQCode
codes
  where
    sub :: String -> ZipList String
sub String
str = case String -> String -> Either String (Int -> Int)
forall (m :: * -> *).
MonadError String m =>
String -> String -> m (Int -> Int)
parseExpr String
var String
str of
                   Right Int -> Int
fun -> [String] -> ZipList String
forall a. [a] -> ZipList a
ZipList ([String] -> ZipList String) -> [String] -> ZipList String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Int -> Int) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
fun (Int -> String) -> [Int] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
ints
                   Left String
_ -> String -> ZipList String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ZipList String) -> String -> ZipList String
forall a b. (a -> b) -> a -> b
$ String
"{" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"}"

unrolls :: String -> [Int] -> [AsmQQCode] -> AsmQQCode
unrolls :: String -> [Int] -> [AsmQQCode] -> AsmQQCode
unrolls String
var [Int]
ints = (AsmQQCode -> AsmQQCode) -> [AsmQQCode] -> AsmQQCode
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((AsmQQCode -> AsmQQCode) -> [AsmQQCode] -> AsmQQCode)
-> (AsmQQCode -> AsmQQCode) -> [AsmQQCode] -> AsmQQCode
forall a b. (a -> b) -> a -> b
$ String -> [Int] -> AsmQQCode -> AsmQQCode
unroll String
var [Int]
ints

substitute :: Applicative f => (String -> f String) -> AsmQQCode -> Either String (f AsmQQCode)
substitute :: (String -> f String) -> AsmQQCode -> Either String (f AsmQQCode)
substitute String -> f String
subst AsmQQCode { String
asmCode :: String
asmCode :: AsmQQCode -> String
.. } = (String -> AsmQQCode) -> f String -> f AsmQQCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> AsmQQCode
AsmQQCode (f String -> f AsmQQCode)
-> Either String (f String) -> Either String (f AsmQQCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String (f String)
go String
asmCode
  where
    go :: String -> Either String (f String)
go (Char
'{' : String
rest)
      | (String
argStr, Char
'}' : String
rest') <- (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'}') String
rest
      , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
argStr = (String -> String -> String
forall a. Semigroup a => a -> a -> a
(<>) (String -> String -> String) -> f String -> f (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> f String
subst (String -> String
trim String
argStr) f (String -> String) -> f String -> f String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) (f String -> f String)
-> Either String (f String) -> Either String (f String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String (f String)
go String
rest'
      | Bool
otherwise = String -> Either String (f String)
forall a b. a -> Either a b
Left (String -> Either String (f String))
-> String -> Either String (f String)
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse argument: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
20 String
rest String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"..."
    go (Char
x : String
xs) = (String -> String) -> f String -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
:) (f String -> f String)
-> Either String (f String) -> Either String (f String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String (f String)
go String
xs
    go [] = f String -> Either String (f String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f String -> Either String (f String))
-> f String -> Either String (f String)
forall a b. (a -> b) -> a -> b
$ String -> f String
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

substituteArgs :: AsmQQType -> AsmQQCode -> Either String AsmQQCode
substituteArgs :: AsmQQType -> AsmQQCode -> Either String AsmQQCode
substituteArgs AsmQQType { [(AsmVarName, AsmVarType)]
rets :: AsmQQType -> [(AsmVarName, AsmVarType)]
args :: AsmQQType -> [(AsmVarName, AsmVarType)]
rets :: [(AsmVarName, AsmVarType)]
args :: [(AsmVarName, AsmVarType)]
.. } AsmQQCode
asmCode = do
  [(AsmVarName, RegName)]
argRegs <- [(AsmVarName, AsmVarType)] -> Either String [(AsmVarName, RegName)]
computeRegisters [(AsmVarName, AsmVarType)]
args
  [(AsmVarName, RegName)]
retRegs <- [(AsmVarName, AsmVarType)] -> Either String [(AsmVarName, RegName)]
computeRegisters [(AsmVarName, AsmVarType)]
rets
  StateT (Map AsmVarName RegName) (Either String) AsmQQCode
res <- (String -> StateT (Map AsmVarName RegName) (Either String) String)
-> AsmQQCode
-> Either
     String (StateT (Map AsmVarName RegName) (Either String) AsmQQCode)
forall (f :: * -> *).
Applicative f =>
(String -> f String) -> AsmQQCode -> Either String (f AsmQQCode)
substitute String -> StateT (Map AsmVarName RegName) (Either String) String
forall (m :: * -> *).
(MonadState (Map AsmVarName RegName) m, MonadError String m) =>
String -> m String
subst AsmQQCode
asmCode
  StateT (Map AsmVarName RegName) (Either String) AsmQQCode
-> Map AsmVarName RegName -> Either String AsmQQCode
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (Map AsmVarName RegName) (Either String) AsmQQCode
res (Map AsmVarName RegName -> Either String AsmQQCode)
-> Map AsmVarName RegName -> Either String AsmQQCode
forall a b. (a -> b) -> a -> b
$ [(AsmVarName, RegName)] -> Map AsmVarName RegName
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(AsmVarName, RegName)] -> Map AsmVarName RegName)
-> [(AsmVarName, RegName)] -> Map AsmVarName RegName
forall a b. (a -> b) -> a -> b
$ [(AsmVarName, RegName)]
retRegs [(AsmVarName, RegName)]
-> [(AsmVarName, RegName)] -> [(AsmVarName, RegName)]
forall a. Semigroup a => a -> a -> a
<> [(AsmVarName, RegName)]
argRegs
  where
    subst :: String -> m String
subst String
arg | String
"move" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
arg = String -> m String
moveReg String
arg
              | Bool
otherwise = do
        let var :: AsmVarName
var = String -> AsmVarName
AsmVarName String
arg
        Maybe RegName
maybeReg <- (Map AsmVarName RegName -> Maybe RegName) -> m (Maybe RegName)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Map AsmVarName RegName -> Maybe RegName) -> m (Maybe RegName))
-> (Map AsmVarName RegName -> Maybe RegName) -> m (Maybe RegName)
forall a b. (a -> b) -> a -> b
$ \Map AsmVarName RegName
regMap -> AsmVarName -> Map AsmVarName RegName -> Maybe RegName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AsmVarName
var Map AsmVarName RegName
regMap
        RegName String
reg <- Either String RegName -> m RegName
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either String RegName -> m RegName)
-> Either String RegName -> m RegName
forall a b. (a -> b) -> a -> b
$ String -> Maybe RegName -> Either String RegName
forall b a. b -> Maybe a -> Either b a
maybeToRight (String
"Unknown argument: `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AsmVarName -> String
forall a. Show a => a -> String
show AsmVarName
var String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`") Maybe RegName
maybeReg
        String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: String
reg

    moveReg :: String -> m String
moveReg (String -> [String]
words -> [String
"move", String
regName, String
reg]) = do
      String
oldReg <- String -> m String
subst String
regName
      let mov :: String
mov = String
"mov " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
oldReg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", %" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
reg
      (Map AsmVarName RegName -> Map AsmVarName RegName) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Map AsmVarName RegName -> Map AsmVarName RegName) -> m ())
-> (Map AsmVarName RegName -> Map AsmVarName RegName) -> m ()
forall a b. (a -> b) -> a -> b
$ AsmVarName
-> RegName -> Map AsmVarName RegName -> Map AsmVarName RegName
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (String -> AsmVarName
AsmVarName String
regName) (String -> RegName
RegName String
reg)
      String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
mov
    moveReg String
s = String -> m String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"Unable to parse move command `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`"

newtype RegName = RegName { RegName -> String
regName :: String } deriving (Int -> RegName -> String -> String
[RegName] -> String -> String
RegName -> String
(Int -> RegName -> String -> String)
-> (RegName -> String)
-> ([RegName] -> String -> String)
-> Show RegName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [RegName] -> String -> String
$cshowList :: [RegName] -> String -> String
show :: RegName -> String
$cshow :: RegName -> String
showsPrec :: Int -> RegName -> String -> String
$cshowsPrec :: Int -> RegName -> String -> String
Show, String -> RegName
(String -> RegName) -> IsString RegName
forall a. (String -> a) -> IsString a
fromString :: String -> RegName
$cfromString :: String -> RegName
IsString)

computeRegisters :: [(AsmVarName, AsmVarType)] -> Either String [(AsmVarName, RegName)]
computeRegisters :: [(AsmVarName, AsmVarType)] -> Either String [(AsmVarName, RegName)]
computeRegisters [(AsmVarName, AsmVarType)]
vars = ([(AsmVarName, RegName)], Map VarTyCat Int)
-> [(AsmVarName, RegName)]
forall a b. (a, b) -> a
fst (([(AsmVarName, RegName)], Map VarTyCat Int)
 -> [(AsmVarName, RegName)])
-> Either String ([(AsmVarName, RegName)], Map VarTyCat Int)
-> Either String [(AsmVarName, RegName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([(AsmVarName, RegName)], Map VarTyCat Int)
 -> (AsmVarName, AsmVarType)
 -> Either String ([(AsmVarName, RegName)], Map VarTyCat Int))
-> ([(AsmVarName, RegName)], Map VarTyCat Int)
-> [(AsmVarName, AsmVarType)]
-> Either String ([(AsmVarName, RegName)], Map VarTyCat Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(AsmVarName, RegName)], Map VarTyCat Int)
-> (AsmVarName, AsmVarType)
-> Either String ([(AsmVarName, RegName)], Map VarTyCat Int)
handleType ([], Map VarTyCat Int
forall a. Monoid a => a
mempty) [(AsmVarName, AsmVarType)]
vars
  where
    handleType :: ([(AsmVarName, RegName)], Map VarTyCat Int)
-> (AsmVarName, AsmVarType)
-> Either String ([(AsmVarName, RegName)], Map VarTyCat Int)
handleType ([(AsmVarName, RegName)]
regNames, Map VarTyCat Int
regCounts) (AsmVarName
name, AsmVarType
ty) = do
      [(AsmVarName, VarTyCat)]
cats <- AsmVarName -> AsmVarType -> Either String [(AsmVarName, VarTyCat)]
categorize AsmVarName
name AsmVarType
ty
      (([(AsmVarName, RegName)], Map VarTyCat Int)
 -> (AsmVarName, VarTyCat)
 -> Either String ([(AsmVarName, RegName)], Map VarTyCat Int))
-> ([(AsmVarName, RegName)], Map VarTyCat Int)
-> [(AsmVarName, VarTyCat)]
-> Either String ([(AsmVarName, RegName)], Map VarTyCat Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([(AsmVarName, RegName)], Map VarTyCat Int)
-> (AsmVarName, VarTyCat)
-> Either String ([(AsmVarName, RegName)], Map VarTyCat Int)
forall a.
([(a, RegName)], Map VarTyCat Int)
-> (a, VarTyCat)
-> Either String ([(a, RegName)], Map VarTyCat Int)
handleCats ([(AsmVarName, RegName)]
regNames, Map VarTyCat Int
regCounts) [(AsmVarName, VarTyCat)]
cats

    handleCats :: ([(a, RegName)], Map VarTyCat Int)
-> (a, VarTyCat)
-> Either String ([(a, RegName)], Map VarTyCat Int)
handleCats ([(a, RegName)]
regNames, Map VarTyCat Int
regCounts) (a
name, VarTyCat
cat) = do
      RegName
reg <- VarTyCat -> Int -> Either String RegName
argIdxToReg VarTyCat
cat Int
idx
      ([(a, RegName)], Map VarTyCat Int)
-> Either String ([(a, RegName)], Map VarTyCat Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a
name, RegName
reg) (a, RegName) -> [(a, RegName)] -> [(a, RegName)]
forall a. a -> [a] -> [a]
: [(a, RegName)]
regNames, VarTyCat -> Int -> Map VarTyCat Int -> Map VarTyCat Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VarTyCat
cat (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Map VarTyCat Int
regCounts)
      where
        idx :: Int
idx = Int -> VarTyCat -> Map VarTyCat Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 VarTyCat
cat Map VarTyCat Int
regCounts

data VarTyCat = Integer | Other deriving (VarTyCat -> VarTyCat -> Bool
(VarTyCat -> VarTyCat -> Bool)
-> (VarTyCat -> VarTyCat -> Bool) -> Eq VarTyCat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VarTyCat -> VarTyCat -> Bool
$c/= :: VarTyCat -> VarTyCat -> Bool
== :: VarTyCat -> VarTyCat -> Bool
$c== :: VarTyCat -> VarTyCat -> Bool
Eq, Eq VarTyCat
Eq VarTyCat
-> (VarTyCat -> VarTyCat -> Ordering)
-> (VarTyCat -> VarTyCat -> Bool)
-> (VarTyCat -> VarTyCat -> Bool)
-> (VarTyCat -> VarTyCat -> Bool)
-> (VarTyCat -> VarTyCat -> Bool)
-> (VarTyCat -> VarTyCat -> VarTyCat)
-> (VarTyCat -> VarTyCat -> VarTyCat)
-> Ord VarTyCat
VarTyCat -> VarTyCat -> Bool
VarTyCat -> VarTyCat -> Ordering
VarTyCat -> VarTyCat -> VarTyCat
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: VarTyCat -> VarTyCat -> VarTyCat
$cmin :: VarTyCat -> VarTyCat -> VarTyCat
max :: VarTyCat -> VarTyCat -> VarTyCat
$cmax :: VarTyCat -> VarTyCat -> VarTyCat
>= :: VarTyCat -> VarTyCat -> Bool
$c>= :: VarTyCat -> VarTyCat -> Bool
> :: VarTyCat -> VarTyCat -> Bool
$c> :: VarTyCat -> VarTyCat -> Bool
<= :: VarTyCat -> VarTyCat -> Bool
$c<= :: VarTyCat -> VarTyCat -> Bool
< :: VarTyCat -> VarTyCat -> Bool
$c< :: VarTyCat -> VarTyCat -> Bool
compare :: VarTyCat -> VarTyCat -> Ordering
$ccompare :: VarTyCat -> VarTyCat -> Ordering
$cp1Ord :: Eq VarTyCat
Ord, Int -> VarTyCat -> String -> String
[VarTyCat] -> String -> String
VarTyCat -> String
(Int -> VarTyCat -> String -> String)
-> (VarTyCat -> String)
-> ([VarTyCat] -> String -> String)
-> Show VarTyCat
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [VarTyCat] -> String -> String
$cshowList :: [VarTyCat] -> String -> String
show :: VarTyCat -> String
$cshow :: VarTyCat -> String
showsPrec :: Int -> VarTyCat -> String -> String
$cshowsPrec :: Int -> VarTyCat -> String -> String
Show, Int -> VarTyCat
VarTyCat -> Int
VarTyCat -> [VarTyCat]
VarTyCat -> VarTyCat
VarTyCat -> VarTyCat -> [VarTyCat]
VarTyCat -> VarTyCat -> VarTyCat -> [VarTyCat]
(VarTyCat -> VarTyCat)
-> (VarTyCat -> VarTyCat)
-> (Int -> VarTyCat)
-> (VarTyCat -> Int)
-> (VarTyCat -> [VarTyCat])
-> (VarTyCat -> VarTyCat -> [VarTyCat])
-> (VarTyCat -> VarTyCat -> [VarTyCat])
-> (VarTyCat -> VarTyCat -> VarTyCat -> [VarTyCat])
-> Enum VarTyCat
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: VarTyCat -> VarTyCat -> VarTyCat -> [VarTyCat]
$cenumFromThenTo :: VarTyCat -> VarTyCat -> VarTyCat -> [VarTyCat]
enumFromTo :: VarTyCat -> VarTyCat -> [VarTyCat]
$cenumFromTo :: VarTyCat -> VarTyCat -> [VarTyCat]
enumFromThen :: VarTyCat -> VarTyCat -> [VarTyCat]
$cenumFromThen :: VarTyCat -> VarTyCat -> [VarTyCat]
enumFrom :: VarTyCat -> [VarTyCat]
$cenumFrom :: VarTyCat -> [VarTyCat]
fromEnum :: VarTyCat -> Int
$cfromEnum :: VarTyCat -> Int
toEnum :: Int -> VarTyCat
$ctoEnum :: Int -> VarTyCat
pred :: VarTyCat -> VarTyCat
$cpred :: VarTyCat -> VarTyCat
succ :: VarTyCat -> VarTyCat
$csucc :: VarTyCat -> VarTyCat
Enum, VarTyCat
VarTyCat -> VarTyCat -> Bounded VarTyCat
forall a. a -> a -> Bounded a
maxBound :: VarTyCat
$cmaxBound :: VarTyCat
minBound :: VarTyCat
$cminBound :: VarTyCat
Bounded)

categorize :: AsmVarName -> AsmVarType -> Either String [(AsmVarName, VarTyCat)]
categorize :: AsmVarName -> AsmVarType -> Either String [(AsmVarName, VarTyCat)]
categorize AsmVarName
name (AsmVarType String
ty)
  | String
ty String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String -> [String]
forall a. (Semigroup a, IsString a) => a -> [a]
integralFamily String
"Int"
            [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> String -> [String]
forall a. (Semigroup a, IsString a) => a -> [a]
integralFamily String
"Word"
            [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
"Ptr", String
"Unit"]) = [(AsmVarName, VarTyCat)] -> Either String [(AsmVarName, VarTyCat)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(AsmVarName
name, VarTyCat
Integer)]
  | String
ty String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"Float", String
"Double"] = [(AsmVarName, VarTyCat)] -> Either String [(AsmVarName, VarTyCat)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(AsmVarName
name, VarTyCat
Other)]
  where
    integralFamily :: a -> [a]
integralFamily a
base = [a
base, a
base a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"8", a
base a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"16", a
base a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"32", a
base a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"64"]
categorize AsmVarName
name (AsmVarType String
"ByteString") = [(AsmVarName, VarTyCat)] -> Either String [(AsmVarName, VarTyCat)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(AsmVarName
name AsmVarName -> AsmVarName -> AsmVarName
forall a. Semigroup a => a -> a -> a
<> AsmVarName
":ptr", VarTyCat
Integer), (AsmVarName
name AsmVarName -> AsmVarName -> AsmVarName
forall a. Semigroup a => a -> a -> a
<> AsmVarName
":len", VarTyCat
Integer)]
categorize AsmVarName
_ (AsmVarType String
s) = String -> Either String [(AsmVarName, VarTyCat)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String [(AsmVarName, VarTyCat)])
-> String -> Either String [(AsmVarName, VarTyCat)]
forall a b. (a -> b) -> a -> b
$ String
"Unknown register type for variable type `" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"`"

argIdxToReg :: VarTyCat -> Int -> Either String RegName
argIdxToReg :: VarTyCat -> Int -> Either String RegName
argIdxToReg VarTyCat
Integer Int
0 = RegName -> Either String RegName
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegName
"rbx"
argIdxToReg VarTyCat
Integer Int
1 = RegName -> Either String RegName
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegName
"r14"
argIdxToReg VarTyCat
Integer Int
2 = RegName -> Either String RegName
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegName
"rsi"
argIdxToReg VarTyCat
Integer Int
3 = RegName -> Either String RegName
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegName
"rdi"
argIdxToReg VarTyCat
Integer Int
4 = RegName -> Either String RegName
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegName
"r8"
argIdxToReg VarTyCat
Integer Int
5 = RegName -> Either String RegName
forall (f :: * -> *) a. Applicative f => a -> f a
pure RegName
"r9"
argIdxToReg VarTyCat
Other Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
6 = RegName -> Either String RegName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RegName -> Either String RegName)
-> RegName -> Either String RegName
forall a b. (a -> b) -> a -> b
$ String -> RegName
RegName (String -> RegName) -> String -> RegName
forall a b. (a -> b) -> a -> b
$ String
"xmm" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
argIdxToReg VarTyCat
_ Int
n = String -> Either String RegName
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String RegName)
-> String -> Either String RegName
forall a b. (a -> b) -> a -> b
$ String
"Unsupported register index: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n

trim :: String -> String
trim :: String -> String
trim = String -> String
pass (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
pass
  where
    pass :: String -> String
pass = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')

findSplitter :: String -> Either String (String, String)
findSplitter :: String -> Either String (String, String)
findSplitter String
p = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'|') String
p of
                      (String
vars, Char
'|' : String
body) -> (String, String) -> Either String (String, String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
vars, String
body)
                      (String, String)
_ -> String -> Either String (String, String)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Unable to find variable section separator"

expQQ :: (String -> Q Exp) -> QuasiQuoter
expQQ :: (String -> Q Exp) -> QuasiQuoter
expQQ String -> Q Exp
qq = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
qq, quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall b a. b -> a
unsupported, quoteType :: String -> Q Type
quoteType = String -> Q Type
forall b a. b -> a
unsupported, quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall b a. b -> a
unsupported }
  where
    unsupported :: b -> a
unsupported = a -> b -> a
forall a b. a -> b -> a
const (a -> b -> a) -> a -> b -> a
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. HasCallStack => String -> a
error String
"Unsupported quasiquotation type"

asmTy :: QuasiQuoter
asmTy :: QuasiQuoter
asmTy = (String -> Q Exp) -> QuasiQuoter
expQQ String -> Q Exp
asmTyQE

asmTyQE :: String -> Q Exp
asmTyQE :: String -> Q Exp
asmTyQE String
str = case String -> Either String AsmQQType
parseAsmTyQQ String
str of
                   Left String
err -> String -> Q Exp
forall a. HasCallStack => String -> a
error String
err
                   Right AsmQQType
parsed -> [e| parsed |]

newtype AsmVarName = AsmVarName { AsmVarName -> String
varName :: String } deriving (Int -> AsmVarName -> String -> String
[AsmVarName] -> String -> String
AsmVarName -> String
(Int -> AsmVarName -> String -> String)
-> (AsmVarName -> String)
-> ([AsmVarName] -> String -> String)
-> Show AsmVarName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AsmVarName] -> String -> String
$cshowList :: [AsmVarName] -> String -> String
show :: AsmVarName -> String
$cshow :: AsmVarName -> String
showsPrec :: Int -> AsmVarName -> String -> String
$cshowsPrec :: Int -> AsmVarName -> String -> String
Show, AsmVarName -> AsmVarName -> Bool
(AsmVarName -> AsmVarName -> Bool)
-> (AsmVarName -> AsmVarName -> Bool) -> Eq AsmVarName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AsmVarName -> AsmVarName -> Bool
$c/= :: AsmVarName -> AsmVarName -> Bool
== :: AsmVarName -> AsmVarName -> Bool
$c== :: AsmVarName -> AsmVarName -> Bool
Eq, Eq AsmVarName
Eq AsmVarName
-> (AsmVarName -> AsmVarName -> Ordering)
-> (AsmVarName -> AsmVarName -> Bool)
-> (AsmVarName -> AsmVarName -> Bool)
-> (AsmVarName -> AsmVarName -> Bool)
-> (AsmVarName -> AsmVarName -> Bool)
-> (AsmVarName -> AsmVarName -> AsmVarName)
-> (AsmVarName -> AsmVarName -> AsmVarName)
-> Ord AsmVarName
AsmVarName -> AsmVarName -> Bool
AsmVarName -> AsmVarName -> Ordering
AsmVarName -> AsmVarName -> AsmVarName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AsmVarName -> AsmVarName -> AsmVarName
$cmin :: AsmVarName -> AsmVarName -> AsmVarName
max :: AsmVarName -> AsmVarName -> AsmVarName
$cmax :: AsmVarName -> AsmVarName -> AsmVarName
>= :: AsmVarName -> AsmVarName -> Bool
$c>= :: AsmVarName -> AsmVarName -> Bool
> :: AsmVarName -> AsmVarName -> Bool
$c> :: AsmVarName -> AsmVarName -> Bool
<= :: AsmVarName -> AsmVarName -> Bool
$c<= :: AsmVarName -> AsmVarName -> Bool
< :: AsmVarName -> AsmVarName -> Bool
$c< :: AsmVarName -> AsmVarName -> Bool
compare :: AsmVarName -> AsmVarName -> Ordering
$ccompare :: AsmVarName -> AsmVarName -> Ordering
$cp1Ord :: Eq AsmVarName
Ord, AsmVarName -> Q Exp
AsmVarName -> Q (TExp AsmVarName)
(AsmVarName -> Q Exp)
-> (AsmVarName -> Q (TExp AsmVarName)) -> Lift AsmVarName
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: AsmVarName -> Q (TExp AsmVarName)
$cliftTyped :: AsmVarName -> Q (TExp AsmVarName)
lift :: AsmVarName -> Q Exp
$clift :: AsmVarName -> Q Exp
Lift, b -> AsmVarName -> AsmVarName
NonEmpty AsmVarName -> AsmVarName
AsmVarName -> AsmVarName -> AsmVarName
(AsmVarName -> AsmVarName -> AsmVarName)
-> (NonEmpty AsmVarName -> AsmVarName)
-> (forall b. Integral b => b -> AsmVarName -> AsmVarName)
-> Semigroup AsmVarName
forall b. Integral b => b -> AsmVarName -> AsmVarName
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> AsmVarName -> AsmVarName
$cstimes :: forall b. Integral b => b -> AsmVarName -> AsmVarName
sconcat :: NonEmpty AsmVarName -> AsmVarName
$csconcat :: NonEmpty AsmVarName -> AsmVarName
<> :: AsmVarName -> AsmVarName -> AsmVarName
$c<> :: AsmVarName -> AsmVarName -> AsmVarName
Semigroup, String -> AsmVarName
(String -> AsmVarName) -> IsString AsmVarName
forall a. (String -> a) -> IsString a
fromString :: String -> AsmVarName
$cfromString :: String -> AsmVarName
IsString)
newtype AsmVarType = AsmVarType { AsmVarType -> String
varType :: String } deriving (Int -> AsmVarType -> String -> String
[AsmVarType] -> String -> String
AsmVarType -> String
(Int -> AsmVarType -> String -> String)
-> (AsmVarType -> String)
-> ([AsmVarType] -> String -> String)
-> Show AsmVarType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AsmVarType] -> String -> String
$cshowList :: [AsmVarType] -> String -> String
show :: AsmVarType -> String
$cshow :: AsmVarType -> String
showsPrec :: Int -> AsmVarType -> String -> String
$cshowsPrec :: Int -> AsmVarType -> String -> String
Show, AsmVarType -> AsmVarType -> Bool
(AsmVarType -> AsmVarType -> Bool)
-> (AsmVarType -> AsmVarType -> Bool) -> Eq AsmVarType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AsmVarType -> AsmVarType -> Bool
$c/= :: AsmVarType -> AsmVarType -> Bool
== :: AsmVarType -> AsmVarType -> Bool
$c== :: AsmVarType -> AsmVarType -> Bool
Eq, Eq AsmVarType
Eq AsmVarType
-> (AsmVarType -> AsmVarType -> Ordering)
-> (AsmVarType -> AsmVarType -> Bool)
-> (AsmVarType -> AsmVarType -> Bool)
-> (AsmVarType -> AsmVarType -> Bool)
-> (AsmVarType -> AsmVarType -> Bool)
-> (AsmVarType -> AsmVarType -> AsmVarType)
-> (AsmVarType -> AsmVarType -> AsmVarType)
-> Ord AsmVarType
AsmVarType -> AsmVarType -> Bool
AsmVarType -> AsmVarType -> Ordering
AsmVarType -> AsmVarType -> AsmVarType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AsmVarType -> AsmVarType -> AsmVarType
$cmin :: AsmVarType -> AsmVarType -> AsmVarType
max :: AsmVarType -> AsmVarType -> AsmVarType
$cmax :: AsmVarType -> AsmVarType -> AsmVarType
>= :: AsmVarType -> AsmVarType -> Bool
$c>= :: AsmVarType -> AsmVarType -> Bool
> :: AsmVarType -> AsmVarType -> Bool
$c> :: AsmVarType -> AsmVarType -> Bool
<= :: AsmVarType -> AsmVarType -> Bool
$c<= :: AsmVarType -> AsmVarType -> Bool
< :: AsmVarType -> AsmVarType -> Bool
$c< :: AsmVarType -> AsmVarType -> Bool
compare :: AsmVarType -> AsmVarType -> Ordering
$ccompare :: AsmVarType -> AsmVarType -> Ordering
$cp1Ord :: Eq AsmVarType
Ord, AsmVarType -> Q Exp
AsmVarType -> Q (TExp AsmVarType)
(AsmVarType -> Q Exp)
-> (AsmVarType -> Q (TExp AsmVarType)) -> Lift AsmVarType
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: AsmVarType -> Q (TExp AsmVarType)
$cliftTyped :: AsmVarType -> Q (TExp AsmVarType)
lift :: AsmVarType -> Q Exp
$clift :: AsmVarType -> Q Exp
Lift)

data AsmQQType = AsmQQType
 { AsmQQType -> [(AsmVarName, AsmVarType)]
args :: [(AsmVarName, AsmVarType)]
 , AsmQQType -> [(AsmVarName, AsmVarType)]
rets :: [(AsmVarName, AsmVarType)]
 } deriving (Int -> AsmQQType -> String -> String
[AsmQQType] -> String -> String
AsmQQType -> String
(Int -> AsmQQType -> String -> String)
-> (AsmQQType -> String)
-> ([AsmQQType] -> String -> String)
-> Show AsmQQType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AsmQQType] -> String -> String
$cshowList :: [AsmQQType] -> String -> String
show :: AsmQQType -> String
$cshow :: AsmQQType -> String
showsPrec :: Int -> AsmQQType -> String -> String
$cshowsPrec :: Int -> AsmQQType -> String -> String
Show, AsmQQType -> Q Exp
AsmQQType -> Q (TExp AsmQQType)
(AsmQQType -> Q Exp)
-> (AsmQQType -> Q (TExp AsmQQType)) -> Lift AsmQQType
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: AsmQQType -> Q (TExp AsmQQType)
$cliftTyped :: AsmQQType -> Q (TExp AsmQQType)
lift :: AsmQQType -> Q Exp
$clift :: AsmQQType -> Q Exp
Lift)

parseAsmTyQQ :: String -> Either String AsmQQType
parseAsmTyQQ :: String -> Either String AsmQQType
parseAsmTyQQ String
str = do
  (String
inputStr, String
outputStr) <- String -> Either String (String, String)
findSplitter String
str
  [(AsmVarName, AsmVarType)]
args <- (ParseErrorBundle String Void -> String)
-> Either (ParseErrorBundle String Void) [(AsmVarName, AsmVarType)]
-> Either String [(AsmVarName, AsmVarType)]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle String Void -> String
showParseError (Either (ParseErrorBundle String Void) [(AsmVarName, AsmVarType)]
 -> Either String [(AsmVarName, AsmVarType)])
-> Either (ParseErrorBundle String Void) [(AsmVarName, AsmVarType)]
-> Either String [(AsmVarName, AsmVarType)]
forall a b. (a -> b) -> a -> b
$ Parsec Void String [(AsmVarName, AsmVarType)]
-> String
-> String
-> Either (ParseErrorBundle String Void) [(AsmVarName, AsmVarType)]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void String [(AsmVarName, AsmVarType)]
forall (m :: * -> *) e.
MonadParsec e String m =>
m [(AsmVarName, AsmVarType)]
parseInTypes Parsec Void String [(AsmVarName, AsmVarType)]
-> ParsecT Void String Identity ()
-> Parsec Void String [(AsmVarName, AsmVarType)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"" String
inputStr
  [(AsmVarName, AsmVarType)]
rets <- (ParseErrorBundle String Void -> String)
-> Either (ParseErrorBundle String Void) [(AsmVarName, AsmVarType)]
-> Either String [(AsmVarName, AsmVarType)]
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle String Void -> String
showParseError (Either (ParseErrorBundle String Void) [(AsmVarName, AsmVarType)]
 -> Either String [(AsmVarName, AsmVarType)])
-> Either (ParseErrorBundle String Void) [(AsmVarName, AsmVarType)]
-> Either String [(AsmVarName, AsmVarType)]
forall a b. (a -> b) -> a -> b
$ Parsec Void String [(AsmVarName, AsmVarType)]
-> String
-> String
-> Either (ParseErrorBundle String Void) [(AsmVarName, AsmVarType)]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec Void String [(AsmVarName, AsmVarType)]
forall (m :: * -> *) e.
MonadParsec e String m =>
m [(AsmVarName, AsmVarType)]
parseInTypes Parsec Void String [(AsmVarName, AsmVarType)]
-> ParsecT Void String Identity ()
-> Parsec Void String [(AsmVarName, AsmVarType)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"" String
outputStr
  AsmQQType -> Either String AsmQQType
forall (f :: * -> *) a. Applicative f => a -> f a
pure AsmQQType :: [(AsmVarName, AsmVarType)]
-> [(AsmVarName, AsmVarType)] -> AsmQQType
AsmQQType { [(AsmVarName, AsmVarType)]
rets :: [(AsmVarName, AsmVarType)]
args :: [(AsmVarName, AsmVarType)]
rets :: [(AsmVarName, AsmVarType)]
args :: [(AsmVarName, AsmVarType)]
.. }

showParseError :: ParseErrorBundle String Void -> String
showParseError :: ParseErrorBundle String Void -> String
showParseError = ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty

parseInTypes :: forall m e. MonadParsec e String m => m [(AsmVarName, AsmVarType)]
parseInTypes :: m [(AsmVarName, AsmVarType)]
parseInTypes = m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space m ()
-> m [(AsmVarName, AsmVarType)] -> m [(AsmVarName, AsmVarType)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m (AsmVarName, AsmVarType) -> m [(AsmVarName, AsmVarType)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many m (AsmVarName, AsmVarType)
parseType
  where
    parseType :: m (AsmVarName, AsmVarType)
parseType = do
      m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m ()) -> m String -> m ()
forall a b. (a -> b) -> a -> b
$ m String -> m String
forall a. m a -> m a
lexeme (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ Tokens String -> m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"("
      String
name <- m String -> m String
forall a. m a -> m a
lexeme (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ m Char -> m String
parseWFirst m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar m String -> m String -> m String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens String -> m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"_"
      m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m ()) -> m String -> m ()
forall a b. (a -> b) -> a -> b
$ m String -> m String
forall a. m a -> m a
lexeme (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ Tokens String -> m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
":"
      String
ty <- m String -> m String
forall a. m a -> m a
lexeme (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ m Char -> m String
parseWFirst m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
      m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m ()) -> m String -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> (Token String -> Bool) -> m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')')
      m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m ()) -> m String -> m ()
forall a b. (a -> b) -> a -> b
$ m String -> m String
forall a. m a -> m a
lexeme (m String -> m String) -> m String -> m String
forall a b. (a -> b) -> a -> b
$ Tokens String -> m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
")"
      (AsmVarName, AsmVarType) -> m (AsmVarName, AsmVarType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> AsmVarName
AsmVarName String
name, String -> AsmVarType
AsmVarType String
ty)

    parseWFirst :: m Char -> m String
    parseWFirst :: m Char -> m String
parseWFirst m Char
p = do
      Char
firstLetter <- m Char
p
      String
rest <- Maybe String -> (Token String -> Bool) -> m (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
"variable") Char -> Bool
Token String -> Bool
isAlphaNum
      String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ Char
firstLetter Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest

    lexeme :: m a -> m a
lexeme = m () -> m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
ML.lexeme (m () -> m a -> m a) -> m () -> m a -> m a
forall a b. (a -> b) -> a -> b
$ m () -> m () -> m () -> m ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
ML.space m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 m ()
forall (f :: * -> *) a. Alternative f => f a
empty m ()
forall (f :: * -> *) a. Alternative f => f a
empty

unreflectTy :: AsmQQType -> Q Type
unreflectTy :: AsmQQType -> Q Type
unreflectTy AsmQQType { [(AsmVarName, AsmVarType)]
rets :: [(AsmVarName, AsmVarType)]
args :: [(AsmVarName, AsmVarType)]
rets :: AsmQQType -> [(AsmVarName, AsmVarType)]
args :: AsmQQType -> [(AsmVarName, AsmVarType)]
.. } = do
  Type
retTy <- [(AsmVarName, AsmVarType)] -> Q Type
unreflectRetTy [(AsmVarName, AsmVarType)]
rets
  Either String [Name]
maybeArgTyNames <- [(AsmVarName, AsmVarType)] -> Q (Either String [Name])
lookupTyNames [(AsmVarName, AsmVarType)]
args
  case Either String [Name]
maybeArgTyNames of
       Left String
err -> String -> Q Type
forall a. HasCallStack => String -> a
error String
err
       Right [Name]
argTyNames -> (Name -> Type -> Q Type) -> Type -> [Name] -> Q Type
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Name -> Type -> Q Type
argFolder Type
retTy [Name]
argTyNames
  where
    argFolder :: Name -> Type -> Q Type
argFolder Name
argName Type
funAcc | Name
argName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Ptr = [t| Ptr () -> $(pure funAcc) |]
                             | Bool
otherwise = [t| $(pure $ ConT argName) -> $(pure funAcc) |]

unreflectRetTy :: [(AsmVarName, AsmVarType)] -> Q Type
unreflectRetTy :: [(AsmVarName, AsmVarType)] -> Q Type
unreflectRetTy [] = [t| () |]
unreflectRetTy [(AsmVarName, AsmVarType)]
rets = do
  Either String [Name]
maybeRetTyNames <- [(AsmVarName, AsmVarType)] -> Q (Either String [Name])
lookupTyNames [(AsmVarName, AsmVarType)]
rets
  case Either String [Name]
maybeRetTyNames of
       Left String
err -> String -> Q Type
forall a. HasCallStack => String -> a
error String
err
       Right [Name
tyName] -> if Name
tyName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Ptr
                           then [t| Ptr () |]
                           else Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
tyName
       Right [Name]
retNames -> Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ (Type -> Name -> Type) -> Type -> [Name] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Name -> Type
retFolder (Int -> Type
TupleT (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
retNames) [Name]
retNames
  where
    retFolder :: Type -> Name -> Type
retFolder Type
tupAcc Name
ret | Name
ret Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''Ptr = Type
tupAcc Type -> Type -> Type
`AppT` (Name -> Type
ConT Name
ret Type -> Type -> Type
`AppT` Int -> Type
TupleT Int
0)
                         | Bool
otherwise = Type
tupAcc Type -> Type -> Type
`AppT` Name -> Type
ConT Name
ret

lookupTyNames :: [(AsmVarName, AsmVarType)] -> Q (Either String [Name])
lookupTyNames :: [(AsmVarName, AsmVarType)] -> Q (Either String [Name])
lookupTyNames = ([Either String Name] -> Either String [Name])
-> Q [Either String Name] -> Q (Either String [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either String Name] -> Either String [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Q [Either String Name] -> Q (Either String [Name]))
-> ([(AsmVarName, AsmVarType)] -> Q [Either String Name])
-> [(AsmVarName, AsmVarType)]
-> Q (Either String [Name])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AsmVarName, AsmVarType) -> Q (Either String Name))
-> [(AsmVarName, AsmVarType)] -> Q [Either String Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AsmVarName, AsmVarType) -> Q (Either String Name)
forall a. Show a => (a, AsmVarType) -> Q (Either String Name)
f
  where
    f :: (a, AsmVarType) -> Q (Either String Name)
f (a
name, AsmVarType
ty) = String -> Maybe Name -> Either String Name
forall b a. b -> Maybe a -> Either b a
maybeToRight (String
"Unable to lookup type " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AsmVarType -> String
forall a. Show a => a -> String
show AsmVarType
ty String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" for var " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
name) (Maybe Name -> Either String Name)
-> Q (Maybe Name) -> Q (Either String Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q (Maybe Name)
lookupTypeName (AsmVarType -> String
varType AsmVarType
ty)