Add EAS, Assembler of ETA

docs/CHANGELOG.md

@@ -1,5 +1,9 @@
 # Revision history for helpa
 
+## 0.2.0.0  -- 2020-08-09
+
+* Add EAS, Assembler of ETA
+
 ## 0.1.0.0  -- 2020-08-08
 
 * First version. Released on an unsuspecting world.

docs/INSTALL.md

@@ -19,7 +19,8 @@ curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .
 
 Compile and run with `cabal`:
 ```bash
-cabal update && cabal clean && cabal build && cabal test
+cabal update 
+cabal clean && cabal build && cabal test
 cabal new-test --test-show-details=streaming
 cabal run helpa
 ```

docs/TODO.md

@@ -4,7 +4,7 @@
 
 Features to do:
 * [ ] 🌈 BrainFuck Assembler
-* [ ] ❤️ ETA Assembler
+* [x] ❤️ ETA Assembler
 * [ ] 💛 Funge Assembler
 * [ ] 💚 Piet Assembler
 * [ ] 💙 SubLeq Assembler

helpa.cabal

@@ -32,20 +32,20 @@ library
         HelVM.HelPA.Assemblers.EAS.CodeGenerator
         HelVM.HelPA.Assemblers.EAS.Instruction
         HelVM.HelPA.Assemblers.EAS.Linker
-        HelVM.HelPA.Assemblers.EAS.Translator
-        HelVM.HelPA.Assemblers.WSA.AsmParser
-        HelVM.HelPA.Assemblers.WSA.Instruction
+        HelVM.HelPA.Assemblers.EAS.Reducer
+
         HelVM.HelPA.Common.AsmParserUtil
+        HelVM.HelPA.Common.OrError
         HelVM.HelPA.Common.Util
         HelVM.HelPA.Common.Value
   other-extensions:
   build-depends:
       base
-    , text
     , attoparsec
     , containers
     , mtl
     , split
+    , text
   hs-source-dirs:      src/main/eta
   default-language:    Haskell2010
   ghc-options:         -Wall
@@ -59,14 +59,16 @@ test-suite spec
         HelVM.HelPA.Assemblers.EAS.CodeGeneratorSpec
         HelVM.HelPA.Assemblers.EAS.LinkerSpec
         HelVM.HelPA.Assemblers.EAS.TestData
-        HelVM.HelPA.Assemblers.EAS.TranslatorSpec
-        HelVM.HelPA.Assemblers.WSA.AsmParserSpec
-        HelVM.HelPA.Assemblers.WSA.TestData
+        HelVM.HelPA.Assemblers.EAS.ReducerSpec
+
   other-extensions:
   build-depends:
       base
-    , text
     , attoparsec
+    , containers
+    , mtl
+    , split
+    , text
     , helpa
     , hspec
     , hspec-attoparsec
@@ -80,15 +82,28 @@ test-suite spec
 executable helpa
   main-is:             Main.hs
   other-modules:
+        AppOptions
+
+        HelVM.HelPA.Assemblers.EAS.AsmParser
+        HelVM.HelPA.Assemblers.EAS.Assembler
+        HelVM.HelPA.Assemblers.EAS.CodeGenerator
+        HelVM.HelPA.Assemblers.EAS.Instruction
+        HelVM.HelPA.Assemblers.EAS.Linker
+        HelVM.HelPA.Assemblers.EAS.Reducer
+
+        HelVM.HelPA.Common.AsmParserUtil
+        HelVM.HelPA.Common.OrError
+        HelVM.HelPA.Common.Util
+        HelVM.HelPA.Common.Value
   other-extensions:
   build-depends:
       base
-    , megaparsec
-    , parser-combinators
     , attoparsec
+    , containers
+    , mtl
+    , split
     , text
     , optparse-applicative
-    , pretty-simple
   hs-source-dirs:      src/main/eta
   default-language:    Haskell2010
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N

src/main/eta/AppOptions.hs

@@ -0,0 +1,40 @@
+{-# Language DataKinds          #-}
+{-# Language ExplicitNamespaces #-}
+
+module AppOptions where
+
+import Options.Applicative
+
+import Text.Read
+
+optionParser :: Parser AppOptions
+optionParser = AppOptions
+  <$> strOption    (  long    "lang"
+                   <> short   'l'
+                   <> metavar "[LANG]"
+                   <> help   ("Language to assembly " ++ show langs)
+                   <> value (show HAPAPL)
+                   <> showDefault
+                   )
+  <*> argument str (  metavar "DIR")
+  <*> argument str (  metavar "FILE")
+
+
+data AppOptions = AppOptions
+  { lang         :: String --Lang
+  , dir          :: String
+  , file         :: String
+  }
+
+----
+
+data Lang = HAPAPL | EAS
+  deriving (Eq, Read, Show)
+
+langs :: [Lang]
+langs = [HAPAPL, EAS]
+
+computeLang :: String -> Lang
+computeLang raw = valid $ readMaybe raw where
+  valid (Just a)  = a
+  valid Nothing = error ("Lang '" ++ raw ++ "' is not valid lang. Valid langs are : " ++ show langs)

src/main/eta/HelVM/HelPA/Assemblers/EAS/AsmParser.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE OverloadedStrings #-}
+module HelVM.HelPA.Assemblers.EAS.AsmParser where
+
+import HelVM.HelPA.Assemblers.EAS.Instruction
+
+import HelVM.HelPA.Common.AsmParserUtil
+import HelVM.HelPA.Common.Value
+
+import Control.Applicative
+import Data.Attoparsec.Text hiding (I, D)
+import Data.Char
+import Data.Functor
+
+import qualified Data.Text as T
+
+parseAssembler :: T.Text -> Either String InstructionList
+parseAssembler = parseOnly instructionListParser
+
+instructionListParser :: Parser InstructionList
+instructionListParser = skipManyComment *> skipHorizontalSpace *> many (instructionParser <* skipHorizontalSpace) -- <* endOfInput
+
+instructionParser :: Parser Instruction
+instructionParser =
+  try zeroOperandInstructionParser
+  <|> numberOperandInstructionParser
+  <|> rParser
+  <|> dParser
+  <|> lParser
+  <|> uParser
+  <|> commentParser
+
+----
+
+zeroOperandInstructionParser :: Parser Instruction
+zeroOperandInstructionParser =
+      zeroOperandInstruction E ["E", "dividE"]
+  <|> zeroOperandInstruction T ["T", "Transfer"]
+  <|> zeroOperandInstruction A ["A", "Address"]
+  <|> zeroOperandInstruction O ["O", "Output"]
+  <|> zeroOperandInstruction I ["I", "Input"]
+  <|> zeroOperandInstruction S ["S", "Subtract"]
+  <|> zeroOperandInstruction H ["H", "Halibut"]
+    where zeroOperandInstruction i ts = (asciiCIChoices ts *> endWordParser) $> i
+
+numberOperandInstructionParser :: Parser Instruction
+numberOperandInstructionParser = N <$> (
+      naturalValueParser
+  <|> (asciiCI "N" *> skipHorizontalSpace *> naturalValueParser)
+  <|> (asciiCI "Number" *> endWordParser *> skipHorizontalSpace *> naturalValueParser)
+  )
+
+rParser :: Parser Instruction
+rParser = (skipMany1EndLine *> skipManyComment) $> R
+
+dParser :: Parser Instruction
+dParser = D <$> (char '*' *> fileNameParser <* char '\n')
+
+lParser :: Parser Instruction
+lParser = L <$> (char '>' *> identifierParser <* char ':')
+
+uParser :: Parser Instruction
+uParser = U <$> stringParser
+
+commentParser :: Parser Instruction
+commentParser = skipComment *> rParser
+
+skipManyComment :: Parser [()]
+skipManyComment = many (skipComment <* skipMany1EndLine)
+
+skipComment :: Parser ()
+skipComment = char commentChar *> skipAllToEndOfLine
+
+skipMany1EndLine :: Parser String
+skipMany1EndLine = many1 (char '\n')
+
+----
+
+endWordParser :: Parser T.Text
+endWordParser = takeTill isEndWord
+
+isEndWord :: Char -> Bool
+isEndWord c = isSpace c || (c == commentChar)
+
+commentChar :: Char
+commentChar = '#'
+
+----
+
+naturalValueParser :: Parser NaturalValue
+naturalValueParser = labelNaturalParser <|> naturalRightParser
+
+labelNaturalParser :: Parser NaturalValue
+labelNaturalParser = Variable <$> (char '<' *> many1 letter)
+
+naturalRightParser :: Parser NaturalValue
+naturalRightParser = Literal <$> naturalParser
+
+----
+

src/main/eta/HelVM/HelPA/Assemblers/EAS/Assembler.hs

@@ -0,0 +1,19 @@
+module HelVM.HelPA.Assemblers.EAS.Assembler where
+
+import HelVM.HelPA.Assemblers.EAS.AsmParser
+import HelVM.HelPA.Assemblers.EAS.CodeGenerator
+import HelVM.HelPA.Assemblers.EAS.Linker
+import HelVM.HelPA.Assemblers.EAS.Reducer
+
+import Control.Monad.Except
+
+import qualified Data.Text as T
+
+assemblyIO :: String -> String -> IO (Either String String)
+assemblyIO dirName fileName = runExceptT $ assembly dirName fileName
+
+assembly :: String -> String -> ExceptT String IO String
+assembly dirName fileName = generateCode . reduce <$> link dirName fileName
+
+singleAssembly :: T.Text -> Either String String
+singleAssembly t = generateCode . reduce <$> parseAssembler t

src/main/eta/HelVM/HelPA/Assemblers/EAS/CodeGenerator.hs

@@ -0,0 +1,29 @@
+module HelVM.HelPA.Assemblers.EAS.CodeGenerator where
+
+import HelVM.HelPA.Assemblers.EAS.Instruction
+
+import HelVM.HelPA.Common.Util
+import HelVM.HelPA.Common.Value
+
+import Data.List
+import Numeric.Natural
+
+generateCode :: InstructionList -> String
+generateCode il = show . WhiteInstruction =<< il
+
+newtype WhiteInstruction = WhiteInstruction Instruction
+
+instance Show WhiteInstruction where
+  show (WhiteInstruction (N (Literal  n))) = "N" ++ showValue n ++ "e"
+  show (WhiteInstruction (N (Variable i))) = error $ show i
+  show (WhiteInstruction (D i))            = error $ show i
+  show (WhiteInstruction (U i))            = error $ show i
+  show (WhiteInstruction (L _))            = ""
+  show (WhiteInstruction R)                = "\n"
+  show (WhiteInstruction i)                = show i
+
+showValue :: Natural -> String
+showValue value = naturalToChar <$> naturalToDigits7 value
+
+naturalToChar :: Natural -> Char
+naturalToChar index = ['h', 't', 'a', 'o', 'i', 'n', 's'] `genericIndex` index

src/main/eta/HelVM/HelPA/Assemblers/EAS/Instruction.hs

@@ -0,0 +1,12 @@
+module HelVM.HelPA.Assemblers.EAS.Instruction where
+
+import HelVM.HelPA.Common.Value
+
+data Instruction = E | T | A | O | I | N NaturalValue | S | H | R | D Identifier | L Identifier | U String
+  deriving (Eq, Show, Ord)
+
+type InstructionList = [Instruction]
+
+isLabel :: Instruction -> Bool
+isLabel (L _) = True
+isLabel  _    = False

src/main/eta/HelVM/HelPA/Assemblers/EAS/Linker.hs

@@ -0,0 +1,24 @@
+module HelVM.HelPA.Assemblers.EAS.Linker where
+
+import HelVM.HelPA.Assemblers.EAS.AsmParser
+import HelVM.HelPA.Assemblers.EAS.Instruction
+
+import Control.Monad.Except
+
+import qualified Data.Text.IO as T
+
+linkIO :: String -> String -> IO (Either String InstructionList)
+linkIO dirName fileName = runExceptT $ link dirName fileName 
+
+link :: String -> String -> ExceptT String IO InstructionList
+link dirName fileName = includeFiles $ ExceptT $ parseAssembler <$> T.readFile (dirName ++ "/" ++ fileName) where
+
+  includeFiles :: ExceptT String IO InstructionList -> ExceptT String IO InstructionList
+  includeFiles expect = loadFiles =<< expect
+
+  loadFiles :: InstructionList -> ExceptT String IO InstructionList
+  loadFiles il = concat <$> mapM loadFile il
+
+  loadFile :: Instruction -> ExceptT String IO InstructionList
+  loadFile (D libName) = link dirName libName
+  loadFile i = pure [i]

src/main/eta/HelVM/HelPA/Assemblers/EAS/Reducer.hs

@@ -0,0 +1,55 @@
+module HelVM.HelPA.Assemblers.EAS.Reducer where
+
+import HelVM.HelPA.Assemblers.EAS.Instruction
+
+import HelVM.HelPA.Common.OrError
+import HelVM.HelPA.Common.Util
+import HelVM.HelPA.Common.Value
+
+import Data.List.Split
+import Data.Char
+
+import Numeric.Natural
+
+import qualified Data.Map.Strict as Map
+
+reduce :: InstructionList -> InstructionList
+reduce il = replaceStrings $ replaceLabels addresses il where addresses = addressOfLabels il
+
+----
+
+type LabelAddresses = Map.Map String Natural
+
+addressOfLabels :: InstructionList -> LabelAddresses
+addressOfLabels il = Map.fromList $ toList =<< zip (labelsToStrings2 il) [1..]
+
+labelsToStrings2 :: InstructionList -> [[String]]
+labelsToStrings2 il = labelsToStrings <$> splitOn [R] il
+
+labelsToStrings :: InstructionList -> [String]
+labelsToStrings il = labelToStrings =<< il
+
+labelToStrings :: Instruction -> [String]
+labelToStrings (L s) = [s]
+labelToStrings  _    = []
+
+----
+
+replaceLabels ::  LabelAddresses -> InstructionList -> InstructionList
+replaceLabels addresses il = replaceLabel addresses <$> il
+
+replaceLabel :: LabelAddresses -> Instruction -> Instruction
+replaceLabel addresses (N (Variable l)) = N $ Literal $ findOrError l addresses
+replaceLabel _          i               = i
+
+----
+
+replaceStrings :: InstructionList -> InstructionList
+replaceStrings il = replaceString =<< il
+
+replaceString :: Instruction -> InstructionList
+replaceString (U s) = charToInstruction <$> reverse s 
+replaceString  i    = [i]
+
+charToInstruction :: Char -> Instruction
+charToInstruction c = N $ Literal $ fromIntegral $ ord c