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

The executable module for compilation
-}
{-# LANGUAGE OverloadedStrings #-}
module Htcc.Asm.Generate (
    InputCCode,
    -- * Generator
    casm',
    buildAST,
    execAST
) where

import           Control.Monad                                   (unless, (>=>))
import           Data.Bits                                       (Bits)
import           Data.Foldable                                   (toList)
import qualified Data.Sequence                                   as S
import qualified Data.Text                                       as T
import           System.Exit                                     (exitFailure)
import           Text.PrettyPrint.ANSI.Leijen                    (Doc, blue,
                                                                  bold, char,
                                                                  empty,
                                                                  magenta, red,
                                                                  text, (<+>))

import           Htcc.Parser                                     (ASTResult,
                                                                  ASTs, parse)
import           Htcc.Parser.ConstructionData.Scope.ManagedScope (ASTError)
import           Htcc.Parser.ConstructionData.Scope.Var          (GlobalVars,
                                                                  Literals)
import qualified Htcc.Tokenizer                                  as HT

import           Htcc.Asm.Generate.Core
import           Htcc.Asm.Intrinsic.Operand
import qualified Htcc.Asm.Intrinsic.Structure                    as SI
import qualified Htcc.Asm.Intrinsic.Structure.Section.Text       as IT

import           Htcc.Utils                                      (dropFst4,
                                                                  putDocErr,
                                                                  putDocLnErr,
                                                                  putStrErr,
                                                                  putStrLnErr,
                                                                  toInts, tshow)

-- | input string, C source code
type InputCCode = T.Text

data MessageType = ErrorMessage | WarningMessage
    deriving (MessageType -> MessageType -> Bool
(MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool) -> Eq MessageType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageType -> MessageType -> Bool
$c/= :: MessageType -> MessageType -> Bool
== :: MessageType -> MessageType -> Bool
$c== :: MessageType -> MessageType -> Bool
Eq, Eq MessageType
Eq MessageType =>
(MessageType -> MessageType -> Ordering)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> MessageType)
-> (MessageType -> MessageType -> MessageType)
-> Ord MessageType
MessageType -> MessageType -> Bool
MessageType -> MessageType -> Ordering
MessageType -> MessageType -> MessageType
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 :: MessageType -> MessageType -> MessageType
$cmin :: MessageType -> MessageType -> MessageType
max :: MessageType -> MessageType -> MessageType
$cmax :: MessageType -> MessageType -> MessageType
>= :: MessageType -> MessageType -> Bool
$c>= :: MessageType -> MessageType -> Bool
> :: MessageType -> MessageType -> Bool
$c> :: MessageType -> MessageType -> Bool
<= :: MessageType -> MessageType -> Bool
$c<= :: MessageType -> MessageType -> Bool
< :: MessageType -> MessageType -> Bool
$c< :: MessageType -> MessageType -> Bool
compare :: MessageType -> MessageType -> Ordering
$ccompare :: MessageType -> MessageType -> Ordering
$cp1Ord :: Eq MessageType
Ord, Int -> MessageType
MessageType -> Int
MessageType -> [MessageType]
MessageType -> MessageType
MessageType -> MessageType -> [MessageType]
MessageType -> MessageType -> MessageType -> [MessageType]
(MessageType -> MessageType)
-> (MessageType -> MessageType)
-> (Int -> MessageType)
-> (MessageType -> Int)
-> (MessageType -> [MessageType])
-> (MessageType -> MessageType -> [MessageType])
-> (MessageType -> MessageType -> [MessageType])
-> (MessageType -> MessageType -> MessageType -> [MessageType])
-> Enum MessageType
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 :: MessageType -> MessageType -> MessageType -> [MessageType]
$cenumFromThenTo :: MessageType -> MessageType -> MessageType -> [MessageType]
enumFromTo :: MessageType -> MessageType -> [MessageType]
$cenumFromTo :: MessageType -> MessageType -> [MessageType]
enumFromThen :: MessageType -> MessageType -> [MessageType]
$cenumFromThen :: MessageType -> MessageType -> [MessageType]
enumFrom :: MessageType -> [MessageType]
$cenumFrom :: MessageType -> [MessageType]
fromEnum :: MessageType -> Int
$cfromEnum :: MessageType -> Int
toEnum :: Int -> MessageType
$ctoEnum :: Int -> MessageType
pred :: MessageType -> MessageType
$cpred :: MessageType -> MessageType
succ :: MessageType -> MessageType
$csucc :: MessageType -> MessageType
Enum, MessageType
MessageType -> MessageType -> Bounded MessageType
forall a. a -> a -> Bounded a
maxBound :: MessageType
$cmaxBound :: MessageType
minBound :: MessageType
$cminBound :: MessageType
Bounded)

instance Show MessageType where
    show :: MessageType -> String
show ErrorMessage   = "error"
    show WarningMessage = "warning"

{-# INLINE messageColor #-}
messageColor :: MessageType -> Doc -> Doc
messageColor :: MessageType -> Doc -> Doc
messageColor ErrorMessage   = Doc -> Doc
red
messageColor WarningMessage = Doc -> Doc
magenta

{-# INLINE repSpace #-}
repSpace :: Integral i => i -> MessageType -> IO ()
repSpace :: i -> MessageType -> IO ()
repSpace i :: i
i mest :: MessageType
mest = do
    (Int -> IO ()) -> [Int] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
putStrErr (Text -> IO ()) -> (Int -> Text) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Char -> String) -> Char -> Int -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Char -> String
forall a. Int -> a -> [a]
replicate ' ' (Int -> String) -> (Int -> Int) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Enum a => a -> a
pred) ([Int] -> IO ()) -> [Int] -> IO ()
forall a b. (a -> b) -> a -> b
$ i -> [Int]
forall i. Integral i => i -> [Int]
toInts i
i
    Doc -> IO ()
putDocErr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Doc -> Doc
messageColor MessageType
mest (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
char '^'

{-# INLINE format #-}
format :: T.Text -> Int -> InputCCode -> IO ()
format :: Text -> Int -> Text -> IO ()
format errMesPre :: Text
errMesPre e :: Int
e xs :: Text
xs = do
    Doc -> IO ()
putDocErr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
blue (String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
errMesPre) Doc -> Doc -> Doc
<+> Doc -> Doc
blue (Char -> Doc
char '|') Doc -> Doc -> Doc
<+> Doc
empty
    Text -> IO ()
putStrLnErr (Text -> [Text]
T.lines Text
xs [Text] -> Int -> Text
forall a. [a] -> Int -> a
!! Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
e))
    Text -> IO ()
putStrErr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (Text -> Int
T.length Text
errMesPre) " "
    Doc -> IO ()
putDocErr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc
empty Doc -> Doc -> Doc
<+> Doc -> Doc
blue (Char -> Doc
char '|') Doc -> Doc -> Doc
<+> Doc
empty

parsedMessage :: (Integral i, Show i) => MessageType -> FilePath -> InputCCode -> ASTError i -> IO ()
parsedMessage :: MessageType -> String -> Text -> ASTError i -> IO ()
parsedMessage mest :: MessageType
mest fpath :: String
fpath xs :: Text
xs (s :: Text
s, (i :: TokenLCNums i
i, etk :: Token i
etk)) = do
    Doc -> IO ()
putDocLnErr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
        Doc -> Doc
bold (String -> Doc
text String
fpath) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
bold (Char -> Doc
char ':') Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
        Doc -> Doc
bold (String -> Doc
text (TokenLCNums i -> String
forall a. Show a => a -> String
show TokenLCNums i
i)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
bold (Char -> Doc
char ':') Doc -> Doc -> Doc
<+>
        MessageType -> Doc -> Doc
messageColor MessageType
mest (String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ MessageType -> String
forall a. Show a => a -> String
show MessageType
mest) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> MessageType -> Doc -> Doc
messageColor MessageType
mest (Char -> Doc
char ':') Doc -> Doc -> Doc
<+>
        String -> Doc
text (Text -> String
T.unpack Text
s)
    Text -> Int -> Text -> IO ()
format (Int -> Text -> Text
T.replicate 4 " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> i -> Text
forall a. Show a => a -> Text
tshow (TokenLCNums i -> i
forall i. TokenLCNums i -> i
HT.tkLn TokenLCNums i
i)) (Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ i -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (i -> Int) -> i -> Int
forall a b. (a -> b) -> a -> b
$ TokenLCNums i -> i
forall i. TokenLCNums i -> i
HT.tkLn TokenLCNums i
i) Text
xs
    i -> MessageType -> IO ()
forall i. Integral i => i -> MessageType -> IO ()
repSpace (TokenLCNums i -> i
forall i. TokenLCNums i -> i
HT.tkCn TokenLCNums i
i) MessageType
mest
    Doc -> IO ()
putDocLnErr (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Doc -> Doc
messageColor MessageType
mest (String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Token i -> Int
forall i. Show i => Token i -> Int
HT.length Token i
etk) '~')

-- | the function to output error message
parsedErrExit :: (Integral i, Show i) => FilePath -> InputCCode -> ASTError i -> IO ()
parsedErrExit :: String -> Text -> ASTError i -> IO ()
parsedErrExit fpath :: String
fpath ccode :: Text
ccode err :: ASTError i
err = MessageType -> String -> Text -> ASTError i -> IO ()
forall i.
(Integral i, Show i) =>
MessageType -> String -> Text -> ASTError i -> IO ()
parsedMessage MessageType
ErrorMessage String
fpath Text
ccode ASTError i
err IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure

-- | the function to output warning message
parsedWarn :: (Integral i, Show i) => FilePath -> InputCCode -> S.Seq (ASTError i) -> IO ()
parsedWarn :: String -> Text -> Seq (ASTError i) -> IO ()
parsedWarn fpath :: String
fpath xs :: Text
xs warns :: Seq (ASTError i)
warns = (ASTError i -> IO ()) -> [ASTError i] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (MessageType -> String -> Text -> ASTError i -> IO ()
forall i.
(Integral i, Show i) =>
MessageType -> String -> Text -> ASTError i -> IO ()
parsedMessage MessageType
WarningMessage String
fpath Text
xs) (Seq (ASTError i) -> [ASTError i]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (ASTError i)
warns)

-- | Executor that receives information about the constructed AST,
-- global variables, and literals and composes assembly code
casm' :: (Integral e, Show e, Integral i, IsOperand i, IT.UnaryInstruction i, IT.BinaryInstruction i) => ASTs i -> GlobalVars i -> Literals i -> SI.Asm SI.AsmCodeCtx e ()
casm' :: ASTs i -> GlobalVars i -> Literals i -> Asm AsmCodeCtx e ()
casm' atl :: ASTs i
atl gvars :: GlobalVars i
gvars lits :: Literals i
lits = GlobalVars i -> Literals i -> Asm AsmCodeCtx e ()
forall i e.
(Show i, Ord i, Num i) =>
Map Text (GVar i) -> [Literal i] -> Asm AsmCodeCtx e ()
dataSection GlobalVars i
gvars Literals i
lits Asm AsmCodeCtx e () -> Asm AsmCodeCtx e () -> Asm AsmCodeCtx e ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ASTs i -> Asm AsmCodeCtx e ()
forall e i.
(Integral e, Show e, IsOperand i, Integral i, Show i,
 UnaryInstruction i, BinaryInstruction i) =>
[ATree i] -> Asm AsmCodeCtx e ()
textSection ASTs i
atl

-- | Build AST from string of C source code
buildAST :: (Integral i, Read i, Show i, Bits i) => InputCCode -> ASTResult i
buildAST :: Text -> ASTResult i
buildAST = Text -> Either (ASTError i) [TokenLC i]
forall i.
(Integral i, Read i, Show i) =>
Text -> Either (ASTError i) [TokenLC i]
HT.tokenize (Text -> Either (ASTError i) [TokenLC i])
-> ([TokenLC i] -> ASTResult i) -> Text -> ASTResult i
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [TokenLC i] -> ASTResult i
forall i.
(Show i, Read i, Integral i, Bits i) =>
[TokenLC i] -> ASTResult i
parse

-- | Print warning or error message if building AST from string of C source code has some problems
execAST :: (Integral i, Read i, Show i, Bits i) => Bool -> FilePath -> InputCCode -> IO (Maybe (ASTs i, GlobalVars i, Literals i))
execAST :: Bool
-> String -> Text -> IO (Maybe (ASTs i, GlobalVars i, Literals i))
execAST supWarns :: Bool
supWarns fpath :: String
fpath ccode :: Text
ccode = (((Warnings i, ASTs i, GlobalVars i, Literals i)
  -> IO (Maybe (ASTs i, GlobalVars i, Literals i)))
 -> Either
      (ASTError i) (Warnings i, ASTs i, GlobalVars i, Literals i)
 -> IO (Maybe (ASTs i, GlobalVars i, Literals i)))
-> Either
     (ASTError i) (Warnings i, ASTs i, GlobalVars i, Literals i)
-> ((Warnings i, ASTs i, GlobalVars i, Literals i)
    -> IO (Maybe (ASTs i, GlobalVars i, Literals i)))
-> IO (Maybe (ASTs i, GlobalVars i, Literals i))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ASTError i -> IO (Maybe (ASTs i, GlobalVars i, Literals i)))
-> ((Warnings i, ASTs i, GlobalVars i, Literals i)
    -> IO (Maybe (ASTs i, GlobalVars i, Literals i)))
-> Either
     (ASTError i) (Warnings i, ASTs i, GlobalVars i, Literals i)
-> IO (Maybe (ASTs i, GlobalVars i, Literals i))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (ASTs i, GlobalVars i, Literals i)
-> IO () -> IO (Maybe (ASTs i, GlobalVars i, Literals i))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) Maybe (ASTs i, GlobalVars i, Literals i)
forall a. Maybe a
Nothing (IO () -> IO (Maybe (ASTs i, GlobalVars i, Literals i)))
-> (ASTError i -> IO ())
-> ASTError i
-> IO (Maybe (ASTs i, GlobalVars i, Literals i))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> ASTError i -> IO ()
forall i.
(Integral i, Show i) =>
String -> Text -> ASTError i -> IO ()
parsedErrExit String
fpath Text
ccode)) (Text
-> Either
     (ASTError i) (Warnings i, ASTs i, GlobalVars i, Literals i)
forall i.
(Integral i, Read i, Show i, Bits i) =>
Text -> ASTResult i
buildAST Text
ccode) (((Warnings i, ASTs i, GlobalVars i, Literals i)
  -> IO (Maybe (ASTs i, GlobalVars i, Literals i)))
 -> IO (Maybe (ASTs i, GlobalVars i, Literals i)))
-> ((Warnings i, ASTs i, GlobalVars i, Literals i)
    -> IO (Maybe (ASTs i, GlobalVars i, Literals i)))
-> IO (Maybe (ASTs i, GlobalVars i, Literals i))
forall a b. (a -> b) -> a -> b
$ \xs :: (Warnings i, ASTs i, GlobalVars i, Literals i)
xs@(warns :: Warnings i
warns, _, _, _) ->
    (ASTs i, GlobalVars i, Literals i)
-> Maybe (ASTs i, GlobalVars i, Literals i)
forall a. a -> Maybe a
Just ((Warnings i, ASTs i, GlobalVars i, Literals i)
-> (ASTs i, GlobalVars i, Literals i)
forall a b c d. (a, b, c, d) -> (b, c, d)
dropFst4 (Warnings i, ASTs i, GlobalVars i, Literals i)
xs) Maybe (ASTs i, GlobalVars i, Literals i)
-> IO () -> IO (Maybe (ASTs i, GlobalVars i, Literals i))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
supWarns (String -> Text -> Warnings i -> IO ()
forall i.
(Integral i, Show i) =>
String -> Text -> Seq (ASTError i) -> IO ()
parsedWarn String
fpath Text
ccode Warnings i
warns)