wip: qq

.gitignore

@@ -7,4 +7,3 @@ dist-newstyle
 .ghc.environment.*
 *.tix
 .direnv
-result

README.md

@@ -1,5 +1,7 @@
 # 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\012bar\000baz" -1}
+{z 16, b $g + 32 "foo\nbar\NULbaz" -1}

qbe.cabal

@@ -39,11 +39,15 @@ 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
+    exposed-modules:  Language.QBE Language.QBE.QQ
     -- other-modules:
     other-extensions: DataKinds
                       KindSignatures
@@ -67,6 +71,8 @@ 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,9 +4,6 @@
 {-# 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
@@ -85,21 +82,16 @@ 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, enclose )
+  , space, encloseSep, tupled, comma, equals, braces, lbrace, rbrace )
 -- 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
 ----------------
@@ -108,12 +100,12 @@ import Data.Char (isPrint, isAscii)
 type RawIdent = ShortText
 
 -- | Sigils are used to differentiate the verious types of 'Ident'ifier.
-data Sigil where
+data Sigil
-  AggregateTy :: Sigil
+  = AggregateTy -- ^ @:@
-  Global :: Sigil
+  | Global -- ^ @$@
-  Temporary :: Sigil
+  | Temporary -- ^ @%@
-  Label :: Sigil
+  | Label -- ^ @\@@
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 -- | QBE identifiers. The sigil is represented at the type level, so that
 -- mixing incompatible identifiers is impossible.
@@ -132,7 +124,7 @@ data Sigil where
 --       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, Data)
+  deriving (Show, Eq, Ord, IsString, NFData, Hashable)
 
 instance Pretty (Ident 'AggregateTy) where
   pretty (Ident raw) = pretty ':' <> pretty (TS.toText raw)
@@ -152,7 +144,7 @@ data BaseTy
   | Long -- ^ @l@
   | Single -- ^ @s@
   | Double -- ^ @d@
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty BaseTy where
   pretty Word   = pretty 'w'
@@ -165,7 +157,7 @@ data ExtTy
   = BaseTy BaseTy
   | Byte -- ^ @b@
   | HalfWord -- ^ @h@
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty ExtTy where
   pretty (BaseTy baseTy) = pretty baseTy
@@ -178,14 +170,15 @@ instance Pretty ExtTy where
 -- | Constant/immediate
 data Const
   -- MAYBE just use a signed type
-  = CInt Integer -- ^ Integer
+  = CInt Bool Word64 -- ^ 64 bit integer. The 'Bool' is whether to negate.
   | CSingle Float -- ^ Single-precision float
   | CDouble Double -- ^ Double-precision float
   | CGlobal (Ident 'Global) -- ^ Global symbol
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty Const where
-  pretty (CInt int) = pretty int
+  pretty (CInt negative int) | negative = pretty '-' <> pretty int
+                             | otherwise = pretty int
   pretty (CSingle float) = "s_" <> pretty float
   pretty (CDouble double) = "d_" <> pretty double
   pretty (CGlobal ident) = pretty ident
@@ -196,7 +189,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, Data)
+  deriving (Show, Eq)
 
 instance Pretty Linkage where
   pretty Export = "export"
@@ -218,7 +211,7 @@ type Amount = Word64
 data TypeDef
   = TypeDef (Ident 'AggregateTy) (Maybe Alignment) [(SubTy, Maybe Amount)]
   | Opaque (Ident 'AggregateTy) Alignment Size
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty TypeDef where
   pretty (TypeDef ident alignment def) =
@@ -236,7 +229,7 @@ instance Pretty TypeDef where
 data SubTy
   = SubExtTy ExtTy
   | SubAggregateTy (Ident 'AggregateTy)
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty SubTy where
   pretty (SubExtTy extTy) = pretty extTy
@@ -247,7 +240,7 @@ instance Pretty SubTy where
 
 -- | Global object definition
 data DataDef = DataDef [Linkage] (Ident 'Global) (Maybe Alignment) [Field]
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty DataDef where
   pretty (DataDef linkage ident alignment fields) = vsep
@@ -261,28 +254,18 @@ data DataItem
   = Symbol (Ident 'Global) (Maybe Alignment)
   | String ByteString
   | Const Const
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty DataItem where
   pretty (Symbol ident alignment) =
     hsep $ pretty ident : maybeToList ((pretty '+' <+>) . pretty <$> alignment)
-  -- ~~HACK: hoping that the escape sequences are the same...~~
+  pretty (String bs) = pretty $ show bs -- 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, Data)
+  deriving (Show, Eq)
 
 instance Pretty Field where
   pretty (FieldExtTy extTy items) = pretty extTy <+> hsep (toList $ pretty <$> items)
@@ -293,16 +276,8 @@ 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
+data FuncDef = FuncDef [Linkage] (Maybe AbiTy) (Ident 'Global) (Maybe (Ident 'Temporary)) [Param] Variadic (NonEmpty Block)
-  { linkage :: [Linkage]
+  deriving (Show, Eq)
-  , 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
@@ -317,7 +292,7 @@ instance Pretty FuncDef where
     ]
 
 data AbiTy = AbiBaseTy BaseTy | AbiAggregateTy (Ident 'AggregateTy)
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty AbiTy where
   pretty (AbiBaseTy baseTy) = pretty baseTy
@@ -325,14 +300,14 @@ instance Pretty AbiTy where
 
 -- | Function parameter
 data Param = Param AbiTy (Ident 'Temporary)
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 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, Data)
+  deriving (Show, Eq)
 
 -- | 'Variadic' → @Just "..."@
 -- 'NoVariadic' → @Nothing@
@@ -348,7 +323,7 @@ data Val
   = ValConst Const
   | ValTemporary (Ident 'Temporary)
   | ValGlobal (Ident 'Global)
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty Val where
   pretty (ValConst c) = pretty c
@@ -356,13 +331,8 @@ instance Pretty Val where
   pretty (ValGlobal ident) = pretty ident
 
 -- | Block of instructions beginning with a label and ending with a jump
-data Block = Block
+data Block = Block (Ident 'Label) [Phi] [Inst] Jump
-  { label :: Ident 'Label
+  deriving (Show, Eq)
-  , phis :: [Phi]
-  , insts :: [Inst]
-  , jump :: Jump
-  }
-  deriving (Show, Eq, Data)
 
 instance Pretty Block where
   pretty (Block ident phis insts jump) = hang 4 $ vsep $ concat
@@ -377,7 +347,7 @@ data Jump
   = Jmp (Ident 'Label) -- ^ Unconditional jump
   | Jnz Val (Ident 'Label) (Ident 'Label) -- ^ Conditional jump
   | Ret (Maybe Val) -- ^ Function return
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty Jump where
   pretty (Jmp ident) = "jmp" <+> pretty ident
@@ -393,7 +363,7 @@ instance Pretty Jump where
 -- MAYBE change [PhiArg] to Map (Ident 'Label) Val
 -- | Phi instruction
 data Phi = Phi Assignment [PhiArg]
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty Phi where
   pretty (Phi assignment args) =
@@ -401,7 +371,7 @@ instance Pretty Phi where
 
 -- | Phi instruction argument, associating a 'Val' to a 'Label'
 data PhiArg = PhiArg (Ident 'Label) Val
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty PhiArg where
   pretty (PhiArg label val) = pretty label <+> pretty val
@@ -460,7 +430,7 @@ data Inst
   | VaStart (Ident 'Temporary)
   -- | @vaarg@, fetches the next argument from a variable argument list
   | VaArg Assignment (Ident 'Temporary)
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty Inst where
   pretty (BinaryOp assignment op v1 v2) =
@@ -509,7 +479,7 @@ instance Pretty Inst where
 
 -- | Represents the @%x =t@ part of an instruction.
 data Assignment = Assignment (Ident 'Temporary) BaseTy
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 -- | Infix synonym of 'Assignment'
 pattern (:=) :: Ident 'Temporary -> BaseTy -> Assignment
@@ -520,7 +490,7 @@ instance Pretty Assignment where
 
 -- | Integer representation
 data IntRepr = Signed | Unsigned
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 -- | Binary arithmetic and bit operations
 data BinaryOp
@@ -547,7 +517,7 @@ data BinaryOp
   | Shr
   -- | @shl@
   | Shl
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty BinaryOp where
   pretty Add            = "add"
@@ -579,7 +549,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, Data)
+  deriving (Show, Eq)
 
 instance Pretty Comparison where
   pretty Eq = "eq"
@@ -597,7 +567,7 @@ instance Pretty IntRepr where
 
 -- | Function argument
 data Arg = Arg AbiTy Val
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty Arg where
   pretty (Arg abiTy val) = pretty abiTy <+> pretty val
@@ -607,7 +577,7 @@ instance Pretty Arg where
 
 -- | Datatypre representing a QBE IL source file
 data Program = Program [TypeDef] [DataDef] [FuncDef]
-  deriving (Show, Eq, Data)
+  deriving (Show, Eq)
 
 instance Pretty Program where
   pretty (Program typeDefs dataDefs funcDefs) = vsep $ concat

src/Language/QBE/QQ.hs

@@ -0,0 +1,43 @@
+{-# 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,9 +6,8 @@ module Main (main) where
 
 import Language.QBE
 
-import Test.Tasty (TestTree, testGroup)
+import Test.Tasty (TestTree, defaultMain, 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)
@@ -32,8 +31,8 @@ goldenTests = testGroup "golden tests"
       ]
   , t "type" ([Word, Long, Single, Double], [BaseTy Word, Byte, HalfWord])
   , t "const"
-      [ CInt (-1)
+      [ CInt True 1
-      , CInt 2
+      , CInt False 2
       , CSingle 0.1
       , CDouble (-0.2)
       , CGlobal "global"
@@ -46,17 +45,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 (-1)]
+      , FieldExtTy Byte $ Symbol "g" (Just 32) :| [String "foo\nbar\0baz", Const $ CInt True 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", ValConst (CGlobal "global")]
+  , t "val" [valInt 0, ValTemporary "temporary", ValGlobal "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)) (ValConst (CGlobal "f")) (Just $ valInt 1)
+  , t "call" $ Call (Just ("r", AbiBaseTy Word)) (ValGlobal "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" []
@@ -93,7 +92,8 @@ goldenTests = testGroup "golden tests"
       (renderStrict . layoutPretty defaultLayoutOptions)
 
 valInt :: Int -> Val
-valInt i = ValConst $ CInt $ fromIntegral i
+valInt i | i >= 0 = ValConst $ CInt False $ 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 0) :| []
+      , FieldExtTy Byte $ Const (CInt False 0) :| []
       ]
     helloMain = FuncDef [Export] (Just $ AbiBaseTy Word) "main"
       Nothing [] NoVariadic $
       Block "start"
         []
-        [ Call (Just ("r", AbiBaseTy Word)) (ValConst (CGlobal "puts"))
+        [ Call (Just ("r", AbiBaseTy Word)) (ValGlobal "puts")
             Nothing
-            [Arg (AbiBaseTy Long) $ ValConst (CGlobal "str")]
+            [Arg (AbiBaseTy Long) $ ValGlobal "str"]
             []
         ]
-        (Ret $ Just $ ValConst $ CInt 0)
+        (Ret $ Just $ ValConst $ CInt False 0)
       :| []