{-|
Module      : Htcc.Asm.Intrinsic.Structure.Internal
Description : The modules of intrinsic (x86_64) assembly
Copyright   : (c) roki, 2019
License     : MIT
Maintainer  : falgon53@yahoo.co.jp
Stability   : experimental
Portability : POSIX

The modules of intrinsic (x86_64) assembly
-}
{-# LANGUAGE OverloadedStrings, TupleSections #-}
module Htcc.Asm.Intrinsic.Structure.Internal (
    Asm (..),
    AsmInfo (..),
    AsmCodeCtx,
    unCtx,
    runAsm,
    putStrWithIndent,
    putStrLnWithIndent,
    errCtx,
    writeCurFn,
    section,
    labeled
) where

import           Control.Monad.Finally (MonadFinally (..))
import           Data.IORef            (IORef, newIORef, writeIORef)
import qualified Data.Text             as T
import qualified Data.Text.IO          as T

import           Htcc.Utils            (err)

-- | Counter and label information used when generating assembly code
data AsmInfo e = AsmInfo
    {
        AsmInfo e -> Bool
inLabel :: Bool, -- ^ the flag that indicates whether it is inside the label. If True, indent by single tab,
        AsmInfo e -> IORef e
lblCnt  :: IORef e, -- ^ the label counter
        AsmInfo e -> IORef (Maybe e)
brkCnt  :: IORef (Maybe e), -- ^ the @break@ label counter
        AsmInfo e -> IORef (Maybe e)
cntCnt  :: IORef (Maybe e), -- ^ the @continue@ label counter
        AsmInfo e -> IORef (Maybe Text)
curFn   :: IORef (Maybe T.Text) -- ^ the function being processed
    }

-- | A monad that represents the context of the assembly code
newtype Asm ctx e a = Asm
    {
        Asm ctx e a -> AsmInfo e -> IO a
unAsm :: AsmInfo e -> IO a -- ^ Function that determines the structure of assembly code
    }

instance Functor (Asm ctx e) where
    fmap :: (a -> b) -> Asm ctx e a -> Asm ctx e b
fmap f :: a -> b
f asm :: Asm ctx e a
asm = (AsmInfo e -> IO b) -> Asm ctx e b
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm ((AsmInfo e -> IO b) -> Asm ctx e b)
-> (AsmInfo e -> IO b) -> Asm ctx e b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (IO a -> IO b) -> (AsmInfo e -> IO a) -> AsmInfo e -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Asm ctx e a -> AsmInfo e -> IO a
forall ctx e a. Asm ctx e a -> AsmInfo e -> IO a
unAsm Asm ctx e a
asm

instance Applicative (Asm ctx e) where
    pure :: a -> Asm ctx e a
pure = (AsmInfo e -> IO a) -> Asm ctx e a
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm ((AsmInfo e -> IO a) -> Asm ctx e a)
-> (a -> AsmInfo e -> IO a) -> a -> Asm ctx e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> AsmInfo e -> IO a
forall a b. a -> b -> a
const (IO a -> AsmInfo e -> IO a)
-> (a -> IO a) -> a -> AsmInfo e -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    f :: Asm ctx e (a -> b)
f <*> :: Asm ctx e (a -> b) -> Asm ctx e a -> Asm ctx e b
<*> x :: Asm ctx e a
x = (AsmInfo e -> IO b) -> Asm ctx e b
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm (\ai :: AsmInfo e
ai -> Asm ctx e (a -> b) -> AsmInfo e -> IO (a -> b)
forall ctx e a. Asm ctx e a -> AsmInfo e -> IO a
unAsm Asm ctx e (a -> b)
f AsmInfo e
ai IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Asm ctx e a -> AsmInfo e -> IO a
forall ctx e a. Asm ctx e a -> AsmInfo e -> IO a
unAsm Asm ctx e a
x AsmInfo e
ai)

instance Monad (Asm ctx e) where
    return :: a -> Asm ctx e a
return = a -> Asm ctx e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    x :: Asm ctx e a
x >>= :: Asm ctx e a -> (a -> Asm ctx e b) -> Asm ctx e b
>>= f :: a -> Asm ctx e b
f = (AsmInfo e -> IO b) -> Asm ctx e b
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm (\ai :: AsmInfo e
ai -> Asm ctx e a -> AsmInfo e -> IO a
forall ctx e a. Asm ctx e a -> AsmInfo e -> IO a
unAsm Asm ctx e a
x AsmInfo e
ai IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Asm ctx e b -> AsmInfo e -> IO b)
-> AsmInfo e -> Asm ctx e b -> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Asm ctx e b -> AsmInfo e -> IO b
forall ctx e a. Asm ctx e a -> AsmInfo e -> IO a
unAsm AsmInfo e
ai (Asm ctx e b -> IO b) -> (a -> Asm ctx e b) -> a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Asm ctx e b
f)

instance MonadFinally (Asm ctx e) where
    bracket' :: Asm ctx e r
-> (r -> Maybe α -> Asm ctx e β)
-> (r -> Asm ctx e α)
-> Asm ctx e (α, β)
bracket' a :: Asm ctx e r
a r :: r -> Maybe α -> Asm ctx e β
r mc :: r -> Asm ctx e α
mc = do
        r
r' <- Asm ctx e r
a
        α
a' <- r -> Asm ctx e α
mc r
r'
        (α
a',) (β -> (α, β)) -> Asm ctx e β -> Asm ctx e (α, β)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> Maybe α -> Asm ctx e β
r r
r' (α -> Maybe α
forall a. a -> Maybe a
Just α
a')

instance Semigroup (Asm ctx e a) where
    <> :: Asm ctx e a -> Asm ctx e a -> Asm ctx e a
(<>) = Asm ctx e a -> Asm ctx e a -> Asm ctx e a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

instance Monoid a => Monoid (Asm ctx e a) where
    mempty :: Asm ctx e a
mempty = (AsmInfo e -> IO a) -> Asm ctx e a
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm ((AsmInfo e -> IO a) -> Asm ctx e a)
-> (AsmInfo e -> IO a) -> Asm ctx e a
forall a b. (a -> b) -> a -> b
$ IO a -> AsmInfo e -> IO a
forall a b. a -> b -> a
const (IO a -> AsmInfo e -> IO a) -> IO a -> AsmInfo e -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty
    mappend :: Asm ctx e a -> Asm ctx e a -> Asm ctx e a
mappend = Asm ctx e a -> Asm ctx e a -> Asm ctx e a
forall a. Semigroup a => a -> a -> a
(<>)

-- | Type representing assembly code
data AsmCodeCtx

-- | the function to switch context
unCtx :: Asm ctx e a -> Asm ctx' e a
unCtx :: Asm ctx e a -> Asm ctx' e a
unCtx = (AsmInfo e -> IO a) -> Asm ctx' e a
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm ((AsmInfo e -> IO a) -> Asm ctx' e a)
-> (Asm ctx e a -> AsmInfo e -> IO a)
-> Asm ctx e a
-> Asm ctx' e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Asm ctx e a -> AsmInfo e -> IO a
forall ctx e a. Asm ctx e a -> AsmInfo e -> IO a
unAsm

-- | the executor that outputs assembly code
runAsm :: (Num e, Enum e) => Asm AsmCodeCtx e a -> IO a
runAsm :: Asm AsmCodeCtx e a -> IO a
runAsm asm :: Asm AsmCodeCtx e a
asm = do
    String -> IO ()
putStrLn ".intel_syntax noprefix"
    IORef e
c <- e -> IO (IORef e)
forall a. a -> IO (IORef a)
newIORef 0
    IORef (Maybe e)
brk <- Maybe e -> IO (IORef (Maybe e))
forall a. a -> IO (IORef a)
newIORef Maybe e
forall a. Maybe a
Nothing
    IORef (Maybe e)
cnt <- Maybe e -> IO (IORef (Maybe e))
forall a. a -> IO (IORef a)
newIORef Maybe e
forall a. Maybe a
Nothing
    IORef (Maybe Text)
fn <- Maybe Text -> IO (IORef (Maybe Text))
forall a. a -> IO (IORef a)
newIORef Maybe Text
forall a. Maybe a
Nothing
    Asm AsmCodeCtx e a -> AsmInfo e -> IO a
forall ctx e a. Asm ctx e a -> AsmInfo e -> IO a
unAsm Asm AsmCodeCtx e a
asm (Bool
-> IORef e
-> IORef (Maybe e)
-> IORef (Maybe e)
-> IORef (Maybe Text)
-> AsmInfo e
forall e.
Bool
-> IORef e
-> IORef (Maybe e)
-> IORef (Maybe e)
-> IORef (Maybe Text)
-> AsmInfo e
AsmInfo Bool
False IORef e
c IORef (Maybe e)
brk IORef (Maybe e)
cnt IORef (Maybe Text)
fn)

-- | print a string with indentation, output is broken on a new line
putStrLnWithIndent :: T.Text -> Asm ctx e ()
putStrLnWithIndent :: Text -> Asm ctx e ()
putStrLnWithIndent s :: Text
s = (AsmInfo e -> IO ()) -> Asm ctx e ()
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm ((AsmInfo e -> IO ()) -> Asm ctx e ())
-> (AsmInfo e -> IO ()) -> Asm ctx e ()
forall a b. (a -> b) -> a -> b
$ \x :: AsmInfo e
x -> Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ if AsmInfo e -> Bool
forall e. AsmInfo e -> Bool
inLabel AsmInfo e
x then '\t' Char -> Text -> Text
`T.cons` Text
s else Text
s

-- | print a string with indentation
putStrWithIndent :: T.Text -> Asm ctx e ()
putStrWithIndent :: Text -> Asm ctx e ()
putStrWithIndent s :: Text
s = (AsmInfo e -> IO ()) -> Asm ctx e ()
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm ((AsmInfo e -> IO ()) -> Asm ctx e ())
-> (AsmInfo e -> IO ()) -> Asm ctx e ()
forall a b. (a -> b) -> a -> b
$ \x :: AsmInfo e
x -> Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ if AsmInfo e -> Bool
forall e. AsmInfo e -> Bool
inLabel AsmInfo e
x then '\t' Char -> Text -> Text
`T.cons` Text
s else Text
s

-- | The error context.
-- when this is executed,
-- it will exit the application immediately with `System.Exit.exitFailure` after printing the message.
errCtx :: T.Text -> Asm ctx e ()
errCtx :: Text -> Asm ctx e ()
errCtx = (AsmInfo e -> IO ()) -> Asm ctx e ()
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm ((AsmInfo e -> IO ()) -> Asm ctx e ())
-> (Text -> AsmInfo e -> IO ()) -> Text -> Asm ctx e ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> AsmInfo e -> IO ()
forall a b. a -> b -> a
const (IO () -> AsmInfo e -> IO ())
-> (Text -> IO ()) -> Text -> AsmInfo e -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
err

-- | rewriting functions during processing
writeCurFn :: Maybe T.Text -> Asm ctx e ()
writeCurFn :: Maybe Text -> Asm ctx e ()
writeCurFn fname :: Maybe Text
fname = (AsmInfo e -> IO ()) -> Asm ctx e ()
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm ((AsmInfo e -> IO ()) -> Asm ctx e ())
-> (AsmInfo e -> IO ()) -> Asm ctx e ()
forall a b. (a -> b) -> a -> b
$ \x :: AsmInfo e
x -> IORef (Maybe Text) -> Maybe Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (AsmInfo e -> IORef (Maybe Text)
forall e. AsmInfo e -> IORef (Maybe Text)
curFn AsmInfo e
x) Maybe Text
fname

-- | represents a section of assembly code
section :: T.Text -> Asm ctx e a -> Asm AsmCodeCtx e a
section :: Text -> Asm ctx e a -> Asm AsmCodeCtx e a
section sec :: Text
sec asm :: Asm ctx e a
asm = Text -> Asm AsmCodeCtx e ()
forall ctx e. Text -> Asm ctx e ()
putStrLnWithIndent ('.' Char -> Text -> Text
`T.cons` Text
sec) Asm AsmCodeCtx e () -> Asm AsmCodeCtx e a -> Asm AsmCodeCtx e a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Asm ctx e a -> Asm AsmCodeCtx e a
forall ctx e a ctx'. Asm ctx e a -> Asm ctx' e a
unCtx Asm ctx e a
asm

-- | switch to process in label
labeled :: Asm ctx e a -> Asm ctx e a
labeled :: Asm ctx e a -> Asm ctx e a
labeled asm :: Asm ctx e a
asm = (AsmInfo e -> IO a) -> Asm ctx e a
forall ctx e a. (AsmInfo e -> IO a) -> Asm ctx e a
Asm ((AsmInfo e -> IO a) -> Asm ctx e a)
-> (AsmInfo e -> IO a) -> Asm ctx e a
forall a b. (a -> b) -> a -> b
$ \x :: AsmInfo e
x -> Asm ctx e a -> AsmInfo e -> IO a
forall ctx e a. Asm ctx e a -> AsmInfo e -> IO a
unAsm Asm ctx e a
asm (AsmInfo e -> IO a) -> AsmInfo e -> IO a
forall a b. (a -> b) -> a -> b
$ AsmInfo e
x { inLabel :: Bool
inLabel = Bool
True }