{-# OPTIONS_GHC -Wno-missing-signatures #-}

module Wrench.Translator (
    translate,
    TranslatorResult (..),
) where

import Relude
import Relude.Extra
import Text.Megaparsec (
    ErrorFancy (..),
    ParseError (..),
    ParseErrorBundle (..),
    PosState (..),
    defaultTabWidth,
    initialPos,
    parse,
 )
import Text.Megaparsec.Error (errorBundlePretty)
import Wrench.Machine.Memory
import Wrench.Machine.Types
import Wrench.Translator.Parser
import Wrench.Translator.Parser.Types
import Wrench.Translator.Types

data TranslatorResult mem w = TranslatorResult
    { forall mem w. TranslatorResult mem w -> mem
dump :: !mem
    , forall mem w. TranslatorResult mem w -> HashMap Text w
labels :: !(HashMap Text w)
    , forall mem w. TranslatorResult mem w -> DumpStats
dumpStats :: !DumpStats
    }
    deriving (Int -> TranslatorResult mem w -> ShowS
[TranslatorResult mem w] -> ShowS
TranslatorResult mem w -> String
(Int -> TranslatorResult mem w -> ShowS)
-> (TranslatorResult mem w -> String)
-> ([TranslatorResult mem w] -> ShowS)
-> Show (TranslatorResult mem w)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall mem w.
(Show mem, Show w) =>
Int -> TranslatorResult mem w -> ShowS
forall mem w.
(Show mem, Show w) =>
[TranslatorResult mem w] -> ShowS
forall mem w.
(Show mem, Show w) =>
TranslatorResult mem w -> String
$cshowsPrec :: forall mem w.
(Show mem, Show w) =>
Int -> TranslatorResult mem w -> ShowS
showsPrec :: Int -> TranslatorResult mem w -> ShowS
$cshow :: forall mem w.
(Show mem, Show w) =>
TranslatorResult mem w -> String
show :: TranslatorResult mem w -> String
$cshowList :: forall mem w.
(Show mem, Show w) =>
[TranslatorResult mem w] -> ShowS
showList :: [TranslatorResult mem w] -> ShowS
Show)

data St w
    = St
    { forall w. St w -> w
sOffset :: !w
    , forall w. St w -> [(Text, w)]
sLabels :: ![(Text, w)]
    }
    deriving (Int -> St w -> ShowS
[St w] -> ShowS
St w -> String
(Int -> St w -> ShowS)
-> (St w -> String) -> ([St w] -> ShowS) -> Show (St w)
forall w. Show w => Int -> St w -> ShowS
forall w. Show w => [St w] -> ShowS
forall w. Show w => St w -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall w. Show w => Int -> St w -> ShowS
showsPrec :: Int -> St w -> ShowS
$cshow :: forall w. Show w => St w -> String
show :: St w -> String
$cshowList :: forall w. Show w => [St w] -> ShowS
showList :: [St w] -> ShowS
Show)

evaluateLabels ::
    (ByteSize isa, IsWord w) =>
    [Section isa w Text]
    -> Either Text (HashMap Text w)
evaluateLabels :: forall isa w.
(ByteSize isa, IsWord w) =>
[Section isa w Text] -> Either Text (HashMap Text w)
evaluateLabels [Section isa w Text]
sections =
    let markCodeToken :: St w -> CodeToken t Text -> St w
markCodeToken st' :: St w
st'@St{w
sOffset :: forall w. St w -> w
sOffset :: w
sOffset, [(Text, w)]
sLabels :: forall w. St w -> [(Text, w)]
sLabels :: [(Text, w)]
sLabels} CodeToken t Text
token =
            case CodeToken t Text
token of
                Mnemonic t
m -> St w
st'{sOffset = sOffset + toEnum (byteSize m)}
                Label Text
l -> St w
st'{sLabels = (l, sOffset) : sLabels}
        markDataToken :: St w -> DataToken w Text -> St w
markDataToken st' :: St w
st'@St{w
sOffset :: forall w. St w -> w
sOffset :: w
sOffset, [(Text, w)]
sLabels :: forall w. St w -> [(Text, w)]
sLabels :: [(Text, w)]
sLabels} DataToken{Text
dtLabel :: Text
dtLabel :: forall w l. DataToken w l -> l
dtLabel, DataValue w
dtValue :: DataValue w
dtValue :: forall w l. DataToken w l -> DataValue w
dtValue} =
            St w
st'
                { sOffset = sOffset + toEnum (byteSize dtValue)
                , sLabels = (dtLabel, sOffset) : sLabels
                }
        St{sLabels :: forall w. St w -> [(Text, w)]
sLabels = [(Text, w)]
labels} =
            (St w -> Section isa w Text -> St w)
-> St w -> [Section isa w Text] -> St w
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
                ( \st :: St w
st@St{w
sOffset :: forall w. St w -> w
sOffset :: w
sOffset} -> \case
                    Code{Maybe Int
org :: Maybe Int
org :: forall isa w l. Section isa w l -> Maybe Int
org, [CodeToken isa Text]
codeTokens :: [CodeToken isa Text]
codeTokens :: forall isa w l. Section isa w l -> [CodeToken isa l]
codeTokens} ->
                        (St w -> CodeToken isa Text -> St w)
-> St w -> [CodeToken isa Text] -> St w
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' St w -> CodeToken isa Text -> St w
forall {w} {t}.
(Num w, Enum w, ByteSize t) =>
St w -> CodeToken t Text -> St w
markCodeToken St w
st{sOffset = maybe sOffset toEnum org} [CodeToken isa Text]
codeTokens
                    Data{Maybe Int
org :: forall isa w l. Section isa w l -> Maybe Int
org :: Maybe Int
org, [DataToken w Text]
dataTokens :: [DataToken w Text]
dataTokens :: forall isa w l. Section isa w l -> [DataToken w l]
dataTokens} ->
                        (St w -> DataToken w Text -> St w)
-> St w -> [DataToken w Text] -> St w
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' St w -> DataToken w Text -> St w
forall {w} {w}.
(Num w, Enum w, ByteSize w, Default w) =>
St w -> DataToken w Text -> St w
markDataToken St w
st{sOffset = maybe sOffset toEnum org} [DataToken w Text]
dataTokens
                )
                St{sOffset :: w
sOffset = w
0, sLabels :: [(Text, w)]
sLabels = []}
                [Section isa w Text]
sections
        collect :: [(Key t, Val t)] -> t -> Either (Key t) t
collect [] t
dict = t -> Either (Key t) t
forall a b. b -> Either a b
Right t
dict
        collect ((Key t
n, Val t
v) : [(Key t, Val t)]
ls) t
dict
            | Key t
n Key t -> t -> Bool
forall t. StaticMap t => Key t -> t -> Bool
`member` t
dict = Key t -> Either (Key t) t
forall a b. a -> Either a b
Left (Key t -> Either (Key t) t) -> Key t -> Either (Key t) t
forall a b. (a -> b) -> a -> b
$ Key t
"Duplicate label: " Key t -> Key t -> Key t
forall a. Semigroup a => a -> a -> a
<> Key t
n
            | Bool
otherwise = [(Key t, Val t)] -> t -> Either (Key t) t
collect [(Key t, Val t)]
ls (Key t -> Val t -> t -> t
forall t. DynamicMap t => Key t -> Val t -> t -> t
insert Key t
n Val t
v t
dict)
     in [(Key (HashMap Text w), Val (HashMap Text w))]
-> HashMap Text w -> Either (Key (HashMap Text w)) (HashMap Text w)
forall {t}.
(Semigroup (Key t), IsString (Key t), DynamicMap t) =>
[(Key t, Val t)] -> t -> Either (Key t) t
collect [(Text, w)]
[(Key (HashMap Text w), Val (HashMap Text w))]
labels ([Item (HashMap Text w)] -> HashMap Text w
forall l. IsList l => [Item l] -> l
fromList [] :: HashMap Text w)

translate ::
    forall isa_ w.
    ( ByteSize (isa_ w (Ref w))
    , ByteSize (isa_ w w)
    , DerefMnemonic (isa_ w) w
    , IsWord w
    , MnemonicParser (isa_ w (Ref w))
    , Show (isa_ w w)
    ) =>
    [Preprocessor]
    -> Int
    -> [Word8]
    -> FilePath
    -> String
    -> Either Text (TranslatorResult (Mem (isa_ w w) w) w)
translate :: forall (isa_ :: * -> * -> *) w.
(ByteSize (isa_ w (Ref w)), ByteSize (isa_ w w),
 DerefMnemonic (isa_ w) w, IsWord w,
 MnemonicParser (isa_ w (Ref w)), Show (isa_ w w)) =>
[Preprocessor]
-> Int
-> [Word8]
-> String
-> String
-> Either Text (TranslatorResult (Mem (isa_ w w) w) w)
translate [Preprocessor]
preprocessors Int
memorySize [Word8]
fillBytes String
fn String
src = do
    src' <- ((Int, Text) -> Text)
-> Either (Int, Text) String -> Either Text String
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> String -> (Int, Text) -> Text
preprocessorError String
fn String
src) (Either (Int, Text) String -> Either Text String)
-> Either (Int, Text) String -> Either Text String
forall a b. (a -> b) -> a -> b
$ [Preprocessor] -> Preprocessor
preprocess [Preprocessor]
preprocessors String
src
    sections <- first (parseError src) $ parse asmParser fn src'
    labels <- evaluateLabels sections
    let resolveLabel Text
l = HashMap Text w
labels HashMap Text w
-> Key (HashMap Text w) -> Maybe (Val (HashMap Text w))
forall t. StaticMap t => t -> Key t -> Maybe (Val t)
!? Text
Key (HashMap Text w)
l
        code = ((w, Section (isa_ w (Ref w)) w Text) -> Section (isa_ w w) w w)
-> [(w, Section (isa_ w (Ref w)) w Text)]
-> [Section (isa_ w w) w w]
forall a b. (a -> b) -> [a] -> [b]
map ((w -> Section (isa_ w (Ref w)) w Text -> Section (isa_ w w) w w)
-> (w, Section (isa_ w (Ref w)) w Text) -> Section (isa_ w w) w w
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Text -> Maybe w)
-> w -> Section (isa_ w (Ref w)) w Text -> Section (isa_ w w) w w
forall (isa :: * -> *) w.
(ByteSize (isa (Ref w)), DerefMnemonic isa w, IsWord w,
 Show (isa w)) =>
(Text -> Maybe w)
-> w -> Section (isa (Ref w)) w Text -> Section (isa w) w w
derefSection Text -> Maybe w
Text -> Maybe (Val (HashMap Text w))
resolveLabel)) (w
-> [Section (isa_ w (Ref w)) w Text]
-> [(w, Section (isa_ w (Ref w)) w Text)]
forall isa w l.
(ByteSize isa, IsWord w) =>
w -> [Section isa w l] -> [(w, Section isa w l)]
markupSectionOffsets w
0 [Section (isa_ w (Ref w)) w Text]
sections)
    dump <- prepareDump memorySize fillBytes code
    return $ TranslatorResult dump labels (computeDumpStats code)
    where
        parseError :: s -> ParseErrorBundle s e -> Text
parseError s
original err :: ParseErrorBundle s e
err@ParseErrorBundle{PosState s
bundlePosState :: PosState s
bundlePosState :: forall s e. ParseErrorBundle s e -> PosState s
bundlePosState} =
            String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle s e -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle s e
err{bundlePosState = bundlePosState{pstateInput = original}}

preprocessorError :: FilePath -> String -> (Int, Text) -> Text
preprocessorError :: String -> String -> (Int, Text) -> Text
preprocessorError String
fn String
src (Int
offset, Text
msg) =
    String -> Text
forall a. ToText a => a -> Text
toText
        (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty @String @Void
        (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void -> String
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle
            { bundleErrors :: NonEmpty (ParseError String Void)
bundleErrors = Int -> Set (ErrorFancy Void) -> ParseError String Void
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
offset (OneItem (Set (ErrorFancy Void)) -> Set (ErrorFancy Void)
forall x. One x => OneItem x -> x
one (OneItem (Set (ErrorFancy Void)) -> Set (ErrorFancy Void))
-> OneItem (Set (ErrorFancy Void)) -> Set (ErrorFancy Void)
forall a b. (a -> b) -> a -> b
$ String -> ErrorFancy Void
forall e. String -> ErrorFancy e
ErrorFail (String -> ErrorFancy Void) -> String -> ErrorFancy Void
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString Text
msg) ParseError String Void
-> [ParseError String Void] -> NonEmpty (ParseError String Void)
forall a. a -> [a] -> NonEmpty a
:| []
            , bundlePosState :: PosState String
bundlePosState =
                PosState
                    { pstateInput :: String
pstateInput = String
src
                    , pstateOffset :: Int
pstateOffset = Int
0
                    , pstateSourcePos :: SourcePos
pstateSourcePos = String -> SourcePos
initialPos String
fn
                    , pstateTabWidth :: Pos
pstateTabWidth = Pos
defaultTabWidth
                    , pstateLinePrefix :: String
pstateLinePrefix = String
""
                    }
            }