Use ByteString

Author: nojima

kaleidoscope-hs/app/Main.hs

@@ -1,14 +1,15 @@
 module Main where
 
-import Control.Monad.Trans
-import Data.Text (Text)
+import Control.Monad.Trans ( MonadIO(liftIO) )
+import Data.ByteString.UTF8 (ByteString)
+import Data.ByteString.UTF8 qualified as ByteString
 import Data.Text qualified as Text
 import Data.Text.IO qualified as Text
 import System.Console.Haskeline qualified as Haskeline
 
 import AST.Parse qualified as Parse
 
-process :: Text -> IO ()
+process :: ByteString -> IO ()
 process line = do
   let res = Parse.parse line
   case res of
@@ -26,7 +27,8 @@ main =
         Nothing ->
           Haskeline.outputStrLn "Goodbye."
         Just input -> do
-          liftIO (process (Text.pack input))
+          let inputBS = ByteString.fromString input
+          liftIO (process inputBS)
           loop
   in
   Haskeline.runInputT Haskeline.defaultSettings loop

kaleidoscope-hs/kaleidoscope-hs.cabal

@@ -25,6 +25,7 @@ source-repository head
 
 library
   exposed-modules:
+      AST.Codegen
       AST.Parse
       AST.Syntax
   other-modules:
@@ -72,13 +73,16 @@ library
       StrictData
   build-depends:
       base >=4.7 && <5
+    , bytestring
     , containers
     , haskeline
     , llvm-hs
+    , llvm-hs-pure
     , megaparsec
     , mtl
     , parser-combinators
     , text
+    , utf8-string
   default-language: Haskell2010
 
 executable kaleidoscope-hs-exe
@@ -129,14 +133,17 @@ executable kaleidoscope-hs-exe
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
+    , bytestring
     , containers
     , haskeline
     , kaleidoscope-hs
     , llvm-hs
+    , llvm-hs-pure
     , megaparsec
     , mtl
     , parser-combinators
     , text
+    , utf8-string
   default-language: Haskell2010
 
 test-suite kaleidoscope-hs-test
@@ -188,12 +195,15 @@ test-suite kaleidoscope-hs-test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
+    , bytestring
     , containers
     , haskeline
     , kaleidoscope-hs
     , llvm-hs
+    , llvm-hs-pure
     , megaparsec
     , mtl
     , parser-combinators
     , text
+    , utf8-string
   default-language: Haskell2010

kaleidoscope-hs/package.yaml

@@ -21,9 +21,12 @@ description:         Please see the README on GitHub at <https://github.com/gith
 
 dependencies:
 - base >= 4.7 && < 5
+- bytestring
+- utf8-string
 - containers
 - haskeline
 - llvm-hs
+- llvm-hs-pure
 - megaparsec
 - mtl
 - parser-combinators

kaleidoscope-hs/src/AST/Codegen.hs

@@ -0,0 +1,63 @@
+module AST.Codegen where
+
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as ByteString
+import Data.ByteString.Short qualified as ByteString.Short
+import Data.Map (Map)
+import Data.Map qualified as Map
+
+import Control.Monad.State (State, MonadState)
+import Control.Monad.State qualified as State
+
+import LLVM.AST qualified as LLVM
+import LLVM.AST.Global qualified as LLVM
+import LLVM.AST.Linkage qualified as Linkage
+import LLVM.AST.Constant qualified as Constant
+import LLVM.AST.Attribute qualified as Attribute
+import LLVM.AST.CallingConvention qualified as Convention
+import LLVM.AST.FloatingPointPredicate as FloatingPoint
+
+import AST.Syntax (Expr, BinOp)
+import AST.Syntax qualified as Syntax
+
+-------------------------------------------------------------------------------
+
+double :: LLVM.Type
+double = LLVM.FloatingPointType LLVM.DoubleFP
+
+-------------------------------------------------------------------------------
+
+type Names = Map ByteString Int
+
+type SymbolTable = Map ByteString LLVM.Operand
+
+data CodegenState = CodegenState
+  { currentBlock :: LLVM.Name                -- Name of the active block to append to
+  , blocks       :: Map LLVM.Name BlockState -- Blocks for function
+  , symbols      :: SymbolTable              -- Function scope symbol table
+  , blockCount   :: Int                      -- Count of basic blocks
+  , count        :: Word                     -- Count of unnamed instructions
+  , names        :: Names                    -- Name Supply
+  }
+  deriving Show
+
+data BlockState = BlockState
+  { idx :: Int                                  -- Block index
+  , stack :: [LLVM.Named LLVM.Instruction]      -- Stack of instructions
+  , term  :: Maybe (LLVM.Named LLVM.Terminator) -- Block terminator
+  }
+  deriving Show
+
+newtype Codegen a = Codegen (State CodegenState a)
+  deriving (Functor, Applicative, Monad, MonadState CodegenState)
+
+newtype LLVMState a = LLVMState (State LLVM.Module a)
+  deriving (Functor, Applicative, Monad, MonadState LLVM.Module)
+
+runLLVM :: LLVM.Module -> LLVMState a -> LLVM.Module
+runLLVM mod (LLVMState llvm) = State.execState llvm mod
+
+emptyModule :: ByteString -> LLVM.Module
+emptyModule label = LLVM.defaultModule
+  { LLVM.moduleName = ByteString.Short.toShort label
+  }

kaleidoscope-hs/src/AST/Parse.hs

@@ -5,6 +5,8 @@ module AST.Parse
   ) where
 
 import Control.Monad.Combinators.Expr qualified as Combinators
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as ByteString
 import Data.Char qualified as Char
 import Data.Function ((&))
 import Data.List (foldl')
@@ -14,43 +16,64 @@ import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Void (Void)
+import Data.Word (Word8)
 import Text.Megaparsec (Parsec, (<?>))
 import Text.Megaparsec qualified as Parsec
-import Text.Megaparsec.Char qualified as ParsecChar
-import Text.Megaparsec.Char.Lexer qualified as Lexer
+import Text.Megaparsec.Byte qualified as Parsec.Byte
+import Text.Megaparsec.Byte.Lexer qualified as Lexer
 import Text.Megaparsec.Error qualified as ParsecError
 
 import AST.Syntax (Name, Expr)
 import AST.Syntax qualified as Syntax
 
 --------------------------------------------------------------------------------
 
-type Parser a = Parsec Void Text a
+type Parser a = Parsec Void ByteString a
 
 newtype Error = Error Text
 
 --------------------------------------------------------------------------------
 
+isUpper :: Word8 -> Bool
+isUpper c = 65 <= c && c <= 90
+
+isLower :: Word8 -> Bool
+isLower c = 97 <= c && c <= 122
+
+isAlpha :: Word8 -> Bool
+isAlpha c = isUpper c || isLower c
+
+isSpace :: Word8 -> Bool
+isSpace c = c == 9 || c == 10 || c == 13 || c == 32
+
+isNumber :: Word8 -> Bool
+isNumber c = 48 <= c && c <= 57
+
+underscore :: Word8
+underscore = 95
+
+--------------------------------------------------------------------------------
+
 space :: Parser ()
 space =
   Lexer.space
-    ParsecChar.space1
+    Parsec.Byte.space1
     (Lexer.skipLineComment "//")
     (Lexer.skipBlockComment "/*" "*/")
 
 lexeme :: Parser a -> Parser a
 lexeme =
   Lexer.lexeme space
 
-symbol :: Text -> Parser ()
+symbol :: ByteString -> Parser ()
 symbol s =
   () <$ Lexer.symbol space s
 
 float :: Parser Double
 float =
   lexeme Lexer.float
 
-keywords :: Set Text
+keywords :: Set ByteString
 keywords = Set.fromList
   [ "if"
   , "then"
@@ -59,26 +82,26 @@ keywords = Set.fromList
   , "extern"
   ]
 
-keyword :: Text -> Parser ()
+keyword :: ByteString -> Parser ()
 keyword str =
   lexeme $
-    () <$ ParsecChar.string str
-       <* Parsec.notFollowedBy ParsecChar.alphaNumChar
+    () <$ Parsec.Byte.string str
+       <* Parsec.notFollowedBy Parsec.Byte.alphaNumChar
 
-identifierOrKeyword :: Parser Text
+identifierOrKeyword :: Parser ByteString
 identifierOrKeyword =
   let
     alphaChar =
       Parsec.satisfy
-        (\c -> (Char.isAlpha c || c == '_') && Char.isAscii c)
+        (\c -> isAlpha c || c == underscore)
         <?> "alphabet"
 
     alphaNumChars =
       Parsec.takeWhileP
         (Just "alphabets or numbers")
-        (\c -> (Char.isAlpha c || Char.isNumber c || c == '_') && Char.isAscii c)
+        (\c -> isAlpha c || isNumber c || c == underscore)
   in
-  lexeme (Text.cons <$> alphaChar <*> alphaNumChars)
+  lexeme (ByteString.cons <$> alphaChar <*> alphaNumChars)
 
 identifier :: Parser Name
 identifier =
@@ -87,7 +110,7 @@ identifier =
     word <- identifierOrKeyword
     if Set.member word keywords then
       let
-        actual = ParsecError.Tokens (NonEmpty.fromList (Text.unpack word))
+        actual = ParsecError.Tokens (NonEmpty.fromList (ByteString.unpack word))
         expected = ParsecError.Label (NonEmpty.fromList "identifier")
         err = ParsecError.TrivialError offset (Just actual) (Set.singleton expected)
       in
@@ -172,7 +195,7 @@ toplevel =
   *> Parsec.many (defn <* symbol ";")
   <* Parsec.eof
 
-parse :: Text -> Either Error [Expr]
+parse :: ByteString -> Either Error [Expr]
 parse source =
     case Parsec.parse toplevel "<stdin>" source of
         Left errors ->

kaleidoscope-hs/src/AST/Syntax.hs

@@ -1,9 +1,8 @@
 module AST.Syntax where
 
-import Data.Text (Text)
-import Data.Text qualified as Text
+import Data.ByteString.Char8 (ByteString)
 
-type Name = Text
+type Name = ByteString
 
 data Expr
   = Float    Double