fix: escape characters as octal sequences

.gitignore

@@ -6,4 +6,5 @@ dist-newstyle
 *.hi
 .ghc.environment.*
 *.tix
-.direnv
+.direnv
+result

README.md

@@ -1,7 +1,5 @@
 # qbe-hs
 
-**fork of [qbe-hs](https://git.sr.ht/~fgaz/qbe-hs)**
-
 [![Hackage](https://img.shields.io/hackage/v/qbe.svg)](https://hackage.haskell.org/package/qbe)
 [![builds.sr.ht status](https://builds.sr.ht/~fgaz/qbe-hs/commits/master.svg)](https://builds.sr.ht/~fgaz/qbe-hs/commits/master?)
 

flake.nix

@@ -24,7 +24,7 @@
             shell.tools = {
               cabal = {};
               # hlint = {};
-              # haskell-language-server = {};
+              haskell-language-server = {};
             };
             # Non-Haskell shell tools go here
             shell.buildInputs = with final; [

golden/data.qbe

@@ -1,3 +1,3 @@
 export
 data $d = align 8
-{z 16, b $g + 32 "foo\nbar\NULbaz" -1}
+{z 16, b $g + 32 "foo\012bar\000baz" -1}

qbe.cabal

@@ -39,15 +39,11 @@ common common
                  -Wredundant-constraints
                  -Wincomplete-uni-patterns
                  -Wincomplete-record-updates
-                 -fdefer-type-errors
-                 -fno-show-valid-hole-fits
-                 -fdefer-out-of-scope-variables
-                 -Wno-typed-holes
     default-language: Haskell2010
 
 library
     import:           common
-    exposed-modules:  Language.QBE Language.QBE.QQ
+    exposed-modules:  Language.QBE
     -- other-modules:
     other-extensions: DataKinds
                       KindSignatures
@@ -71,8 +67,6 @@ library
                                        || ^>= 1.5.0
                     , deepseq           ^>= 1.4.4 || ^>= 1.5
                     , prettyprinter     ^>= 1.7.1
-                    , megaparsec        ^>= 9.7.0
-                    , template-haskell
     hs-source-dirs:   src
 
 test-suite golden

src/Language/QBE.hs

@@ -4,6 +4,9 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DuplicateRecordFields, NoFieldSelectors #-}
 {-|
 Module      : Language.QBE
 Description : Types and Pretty instances for the QBE IL
@@ -82,16 +85,21 @@ import Data.Text (Text)
 import Data.Text.Short (ShortText)
 import qualified Data.Text.Short as TS
 import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import Data.ByteString.Internal (w2c)
 import Data.Word (Word64)
 import Data.List.NonEmpty (NonEmpty, toList)
 import Data.Maybe (maybeToList)
 import Prettyprinter
   ( Pretty(pretty), Doc, (<+>), vsep, hsep, hang, punctuate, group, flatAlt
-  , space, encloseSep, tupled, comma, equals, braces, lbrace, rbrace )
+  , space, encloseSep, tupled, comma, equals, braces, lbrace, rbrace, enclose )
 -- Instances
 import Data.Hashable (Hashable)
 import Control.DeepSeq (NFData)
 import Data.String (IsString)
+import Data.Data (Data)
+import Numeric (showOct)
+import Data.Char (isPrint, isAscii)
 
 -- * Identifiers
 ----------------
@@ -100,12 +108,12 @@ import Data.String (IsString)
 type RawIdent = ShortText
 
 -- | Sigils are used to differentiate the verious types of 'Ident'ifier.
-data Sigil
+data Sigil where
-  = AggregateTy -- ^ @:@
+  AggregateTy :: Sigil
-  | Global -- ^ @$@
+  Global :: Sigil
-  | Temporary -- ^ @%@
+  Temporary :: Sigil
-  | Label -- ^ @\@@
+  Label :: Sigil
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 -- | QBE identifiers. The sigil is represented at the type level, so that
 -- mixing incompatible identifiers is impossible.
@@ -124,7 +132,7 @@ data Sigil
 --       In the second argument of ‘($)’, namely ‘Jmp $ Ident @'Global "a"’
 --       In the expression: pretty $ Jmp $ Ident @'Global "a"
 newtype Ident (t :: Sigil) = Ident RawIdent
-  deriving (Show, Eq, Ord, IsString, NFData, Hashable)
+  deriving (Show, Eq, Ord, IsString, NFData, Hashable, Data)
 
 instance Pretty (Ident 'AggregateTy) where
   pretty (Ident raw) = pretty ':' <> pretty (TS.toText raw)
@@ -144,7 +152,7 @@ data BaseTy
   | Long -- ^ @l@
   | Single -- ^ @s@
   | Double -- ^ @d@
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty BaseTy where
   pretty Word   = pretty 'w'
@@ -157,7 +165,7 @@ data ExtTy
   = BaseTy BaseTy
   | Byte -- ^ @b@
   | HalfWord -- ^ @h@
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty ExtTy where
   pretty (BaseTy baseTy) = pretty baseTy
@@ -170,15 +178,14 @@ instance Pretty ExtTy where
 -- | Constant/immediate
 data Const
   -- MAYBE just use a signed type
-  = CInt Bool Word64 -- ^ 64 bit integer. The 'Bool' is whether to negate.
+  = CInt Integer -- ^ Integer
   | CSingle Float -- ^ Single-precision float
   | CDouble Double -- ^ Double-precision float
   | CGlobal (Ident 'Global) -- ^ Global symbol
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Const where
-  pretty (CInt negative int) | negative = pretty '-' <> pretty int
+  pretty (CInt int) = pretty int
-                             | otherwise = pretty int
   pretty (CSingle float) = "s_" <> pretty float
   pretty (CDouble double) = "d_" <> pretty double
   pretty (CGlobal ident) = pretty ident
@@ -189,7 +196,7 @@ instance Pretty Const where
 data Linkage
   = Export -- ^ Marks the defined item as visible outside the current file's scope
   | Section ShortText (Maybe Text) -- ^ Section name, with optional linker flags
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Linkage where
   pretty Export = "export"
@@ -211,7 +218,7 @@ type Amount = Word64
 data TypeDef
   = TypeDef (Ident 'AggregateTy) (Maybe Alignment) [(SubTy, Maybe Amount)]
   | Opaque (Ident 'AggregateTy) Alignment Size
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty TypeDef where
   pretty (TypeDef ident alignment def) =
@@ -229,7 +236,7 @@ instance Pretty TypeDef where
 data SubTy
   = SubExtTy ExtTy
   | SubAggregateTy (Ident 'AggregateTy)
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty SubTy where
   pretty (SubExtTy extTy) = pretty extTy
@@ -240,7 +247,7 @@ instance Pretty SubTy where
 
 -- | Global object definition
 data DataDef = DataDef [Linkage] (Ident 'Global) (Maybe Alignment) [Field]
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty DataDef where
   pretty (DataDef linkage ident alignment fields) = vsep
@@ -254,18 +261,28 @@ data DataItem
   = Symbol (Ident 'Global) (Maybe Alignment)
   | String ByteString
   | Const Const
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty DataItem where
   pretty (Symbol ident alignment) =
     hsep $ pretty ident : maybeToList ((pretty '+' <+>) . pretty <$> alignment)
-  pretty (String bs) = pretty $ show bs -- HACK: hoping that the escape sequences are the same...
+  -- ~~HACK: hoping that the escape sequences are the same...~~
+  -- ↑ wrong bitch (it's undocumented; i don't blame you babe.)
+  pretty (String bs) =
+    enclose "\"" "\"" . pretty . showHexSequences . BS.unpack $ bs
+    where
+      showHexSequences =
+        foldr (\a acc -> char a <> acc) ""
+      char c
+        | isAscii (w2c c) && isPrint (w2c c) = [w2c c]
+        | otherwise = "\\" <> pad 3 (showOct c "")
+      pad n s = replicate (max 0 (n - length s)) '0' <> s
   pretty (Const c) = pretty c
 
 data Field
   = FieldExtTy ExtTy (NonEmpty DataItem)
   | FieldZero Size
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Field where
   pretty (FieldExtTy extTy items) = pretty extTy <+> hsep (toList $ pretty <$> items)
@@ -276,8 +293,16 @@ instance Pretty Field where
 
 -- TODO use record syntax on long types like this one
 -- | Function definition. The 'Maybe (Ident \'Temporary)' is the environment
-data FuncDef = FuncDef [Linkage] (Maybe AbiTy) (Ident 'Global) (Maybe (Ident 'Temporary)) [Param] Variadic (NonEmpty Block)
+data FuncDef = FuncDef
-  deriving (Show, Eq)
+  { linkage :: [Linkage]
+  , returnType :: Maybe AbiTy
+  , name :: Ident 'Global
+  , env :: Maybe (Ident 'Temporary)
+  , params :: [Param]
+  , variadic :: Variadic
+  , code :: NonEmpty Block
+  }
+  deriving (Show, Eq, Data)
 
 instance Pretty FuncDef where
   pretty (FuncDef linkage abiTy ident env params variadic blocks) = vsep
@@ -292,7 +317,7 @@ instance Pretty FuncDef where
     ]
 
 data AbiTy = AbiBaseTy BaseTy | AbiAggregateTy (Ident 'AggregateTy)
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty AbiTy where
   pretty (AbiBaseTy baseTy) = pretty baseTy
@@ -300,14 +325,14 @@ instance Pretty AbiTy where
 
 -- | Function parameter
 data Param = Param AbiTy (Ident 'Temporary)
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Param where
   pretty (Param abiTy ident) = pretty abiTy <+> pretty ident
 
 -- | Indicates the presence or absence of a variadic marker
 data Variadic = Variadic | NoVariadic
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 -- | 'Variadic' → @Just "..."@
 -- 'NoVariadic' → @Nothing@
@@ -323,7 +348,7 @@ data Val
   = ValConst Const
   | ValTemporary (Ident 'Temporary)
   | ValGlobal (Ident 'Global)
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Val where
   pretty (ValConst c) = pretty c
@@ -331,8 +356,13 @@ instance Pretty Val where
   pretty (ValGlobal ident) = pretty ident
 
 -- | Block of instructions beginning with a label and ending with a jump
-data Block = Block (Ident 'Label) [Phi] [Inst] Jump
+data Block = Block
-  deriving (Show, Eq)
+  { label :: Ident 'Label
+  , phis :: [Phi]
+  , insts :: [Inst]
+  , jump :: Jump
+  }
+  deriving (Show, Eq, Data)
 
 instance Pretty Block where
   pretty (Block ident phis insts jump) = hang 4 $ vsep $ concat
@@ -347,7 +377,7 @@ data Jump
   = Jmp (Ident 'Label) -- ^ Unconditional jump
   | Jnz Val (Ident 'Label) (Ident 'Label) -- ^ Conditional jump
   | Ret (Maybe Val) -- ^ Function return
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Jump where
   pretty (Jmp ident) = "jmp" <+> pretty ident
@@ -363,7 +393,7 @@ instance Pretty Jump where
 -- MAYBE change [PhiArg] to Map (Ident 'Label) Val
 -- | Phi instruction
 data Phi = Phi Assignment [PhiArg]
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Phi where
   pretty (Phi assignment args) =
@@ -371,7 +401,7 @@ instance Pretty Phi where
 
 -- | Phi instruction argument, associating a 'Val' to a 'Label'
 data PhiArg = PhiArg (Ident 'Label) Val
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty PhiArg where
   pretty (PhiArg label val) = pretty label <+> pretty val
@@ -430,7 +460,7 @@ data Inst
   | VaStart (Ident 'Temporary)
   -- | @vaarg@, fetches the next argument from a variable argument list
   | VaArg Assignment (Ident 'Temporary)
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Inst where
   pretty (BinaryOp assignment op v1 v2) =
@@ -479,7 +509,7 @@ instance Pretty Inst where
 
 -- | Represents the @%x =t@ part of an instruction.
 data Assignment = Assignment (Ident 'Temporary) BaseTy
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 -- | Infix synonym of 'Assignment'
 pattern (:=) :: Ident 'Temporary -> BaseTy -> Assignment
@@ -490,7 +520,7 @@ instance Pretty Assignment where
 
 -- | Integer representation
 data IntRepr = Signed | Unsigned
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 -- | Binary arithmetic and bit operations
 data BinaryOp
@@ -517,7 +547,7 @@ data BinaryOp
   | Shr
   -- | @shl@
   | Shl
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty BinaryOp where
   pretty Add            = "add"
@@ -549,7 +579,7 @@ data Comparison
   -- Floating point only comparison
   | O -- ^ ordered (no operand is a NaN) (floating point only)
   | Uo -- ^ unordered (at least one operand is a NaN) (floating point only)
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Comparison where
   pretty Eq = "eq"
@@ -567,7 +597,7 @@ instance Pretty IntRepr where
 
 -- | Function argument
 data Arg = Arg AbiTy Val
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Arg where
   pretty (Arg abiTy val) = pretty abiTy <+> pretty val
@@ -577,7 +607,7 @@ instance Pretty Arg where
 
 -- | Datatypre representing a QBE IL source file
 data Program = Program [TypeDef] [DataDef] [FuncDef]
-  deriving (Show, Eq)
+  deriving (Show, Eq, Data)
 
 instance Pretty Program where
   pretty (Program typeDefs dataDefs funcDefs) = vsep $ concat

src/Language/QBE/QQ.hs

@@ -1,43 +0,0 @@
-{-# LANGUAGE RankNTypes, TypeAbstractions, OverloadedStrings, ScopedTypeVariables #-}
-module Language.QBE.QQ
-  ( qbe
-  )
-  where
-
-import qualified Language.Haskell.TH as TH
-import Language.Haskell.TH.Quote
-import Data.Void
-import Text.Megaparsec
-import Text.Megaparsec.Char
-import qualified Text.Megaparsec.Char.Lexer as L
-import Language.QBE
-import Data.Proxy
-
-
-type P = Parsec Void String
-
-space = L.space space1 empty empty
-lexeme = L.lexeme space1
-symbol = L.symbol space1
-
-ident :: Sigil -> P (Ident t)
-ident (Proxy @t) = do
-  case t of
-    AggregateTy -> char ':'
-  Ident <$> ""
-
-assignment :: P Assignment
-assignment = do
-  ident
-
-assignmentInst :: P Inst
-assignmentInst = _
-
-qbeQuoteExp :: String -> TH.ExpQ
-qbeQuoteExp = _
-
-qbe :: QuasiQuoter
-qbe = QuasiQuoter
-  { quoteExp = qbeQuoteExp
-  , quotePat = _
-  }

test/Main.hs

@@ -6,8 +6,9 @@ module Main (main) where
 
 import Language.QBE
 
-import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Silver (goldenVsAction)
+import Test.Tasty.Silver.Interactive (defaultMain)
 import System.FilePath ((</>), (<.>))
 import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
 import Prettyprinter.Render.Text (renderStrict)
@@ -31,8 +32,8 @@ goldenTests = testGroup "golden tests"
       ]
   , t "type" ([Word, Long, Single, Double], [BaseTy Word, Byte, HalfWord])
   , t "const"
-      [ CInt True 1
+      [ CInt (-1)
-      , CInt False 2
+      , CInt 2
       , CSingle 0.1
       , CDouble (-0.2)
       , CGlobal "global"
@@ -45,17 +46,17 @@ goldenTests = testGroup "golden tests"
   , t "opaque" $ Opaque "t" 8 16
   , t "data" $ DataDef [Export] "d" (Just 8)
       [ FieldZero 16
-      , FieldExtTy Byte $ Symbol "g" (Just 32) :| [String "foo\nbar\0baz", Const $ CInt True 1]
+      , FieldExtTy Byte $ Symbol "g" (Just 32) :| [String "foo\nbar\0baz", Const $ CInt (-1)]
       ]
   , t "function" $ FuncDef [Export] (Just $ AbiAggregateTy "t") "f"
       (Just "env") [Param (AbiBaseTy Word) "a", Param (AbiBaseTy Double) "b"] Variadic $
       Block "l" [] [] (Ret Nothing) :| []
-  , t "val" [valInt 0, ValTemporary "temporary", ValGlobal "global"]
+  , t "val" [valInt 0, ValTemporary "temporary", ValConst (CGlobal "global")]
   , t "jmp" $ Jmp "target"
   , t "jnz" $ Jnz (valInt 0) "target1" "target2"
   , t "ret" $ Ret $ Just $ ValTemporary "x"
   , t "phi" $ Phi (Assignment "a" Word) [PhiArg "b" $ valInt 1, PhiArg "c" $ valInt 2]
-  , t "call" $ Call (Just ("r", AbiBaseTy Word)) (ValGlobal "f") (Just $ valInt 1)
+  , t "call" $ Call (Just ("r", AbiBaseTy Word)) (ValConst (CGlobal "f")) (Just $ valInt 1)
       [Arg (AbiBaseTy Word) $ valInt 2, Arg (AbiAggregateTy "t") $ ValTemporary "a"]
       [Arg (AbiBaseTy Word) $ valInt 3, Arg (AbiAggregateTy "t1") $ ValTemporary "b"]
   , t "inst" $ Block "l" []
@@ -92,8 +93,7 @@ goldenTests = testGroup "golden tests"
       (renderStrict . layoutPretty defaultLayoutOptions)
 
 valInt :: Int -> Val
-valInt i | i >= 0 = ValConst $ CInt False $ fromIntegral i
+valInt i = ValConst $ CInt $ fromIntegral i
-         | otherwise = ValConst $ CInt True $ fromIntegral $ negate i
 
 one, two :: Val
 one = valInt 1
@@ -107,16 +107,16 @@ helloWorld = Program [] [helloString] [helloMain]
   where
     helloString = DataDef [] "str" Nothing
       [ FieldExtTy Byte $ String "hello world" :| []
-      , FieldExtTy Byte $ Const (CInt False 0) :| []
+      , FieldExtTy Byte $ Const (CInt 0) :| []
       ]
     helloMain = FuncDef [Export] (Just $ AbiBaseTy Word) "main"
       Nothing [] NoVariadic $
       Block "start"
         []
-        [ Call (Just ("r", AbiBaseTy Word)) (ValGlobal "puts")
+        [ Call (Just ("r", AbiBaseTy Word)) (ValConst (CGlobal "puts"))
             Nothing
-            [Arg (AbiBaseTy Long) $ ValGlobal "str"]
+            [Arg (AbiBaseTy Long) $ ValConst (CGlobal "str")]
             []
         ]
-        (Ret $ Just $ ValConst $ CInt False 0)
+        (Ret $ Just $ ValConst $ CInt 0)
       :| []