{-# 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)