Add some Pretty instances

and golden tests

.gitignore

@@ -5,3 +5,4 @@ dist-newstyle
 *.o
 *.hi
 .ghc.environment.*
+*.tix

golden/const.qbe

@@ -0,0 +1 @@
+[-1, 2, s_0.1, d_-0.2, $global]

golden/ident.qbe

@@ -0,0 +1 @@
+[:aggregateTy, $global, %temporary, @label]

golden/jmp.qbe

@@ -0,0 +1 @@
+jmp @target

golden/jnz.qbe

@@ -0,0 +1 @@
+jnz 0, @target1, @target2

golden/linkage.qbe

@@ -0,0 +1 @@
+(export, section secName, section secName flag1 flag2)

golden/opaque.qbe

@@ -0,0 +1 @@
+type :t = align 8 {16}

golden/ret.qbe

@@ -0,0 +1 @@
+ret %x

golden/type.qbe

@@ -0,0 +1 @@
+([w, l, s, d], [w, b, h])

golden/typedef.qbe

@@ -0,0 +1 @@
+type :t = 8 {h 16, :t1}

golden/val.qbe

@@ -0,0 +1 @@
+[0, %temporary, $global]

qbe.cabal

@@ -14,12 +14,24 @@ build-type:         Simple
 extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
+common common
+    ghc-options: -Wall
+                 -Wunused-packages
+                 -Wmissing-home-modules
+                 -Wredundant-constraints
+                 -Wincomplete-uni-patterns
+                 -Wincomplete-record-updates
+    default-language: Haskell2010
+
 library
+    import:           common
     exposed-modules:  Language.QBE
     -- other-modules:
     other-extensions: DataKinds
                       KindSignatures
                       GeneralizedNewtypeDeriving
+                      FlexibleInstances
+                      OverloadedStrings
     build-depends:    base ^>=4.16.1.0
                     , text
                     , text-short
@@ -27,6 +39,21 @@ library
                     , hashable
                     , deepseq
                     , binary
+                    , prettyprinter
     hs-source-dirs:   src
-    ghc-options: -Wall
+
-    default-language: Haskell2010
+test-suite golden
+    import:           common
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          Main.hs
+    build-depends:    base
+                    , qbe
+                    , filepath
+                    , tasty
+                    , tasty-silver
+                    , prettyprinter
+    other-extensions: TypeApplications
+                      OverloadedStrings
+                      DataKinds
+                      ExistentialQuantification

src/Language/QBE.hs

@@ -1,13 +1,19 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Language.QBE where
 
 import Data.Text (Text)
 import Data.Text.Short (ShortText)
+import qualified Data.Text.Short as TS
 import Data.ByteString (ByteString)
 import Data.Word (Word64)
 import Data.List.NonEmpty (NonEmpty)
+import Prettyprinter
+  ( Pretty(pretty), (<+>)
+  , space, encloseSep, lbrace, rbrace, comma, equals, braces )
 -- Instances
 import Data.Hashable (Hashable)
 import Control.DeepSeq (NFData)
@@ -28,18 +34,52 @@ data Sigil
 
 -- | QBE identifiers. The sigil is represented at the type level, so that
 -- mixing incompatible identifiers is impossible.
+--
+-- >>> :set -XOverloadedStrings
+-- >>> :set -XDataKinds
+-- >>> :set -XTypeApplications
+-- >>> pretty $ Jmp $ Ident @'Label "a"
+-- jmp @a
+-- >>> pretty $ Jmp $ Ident @'Global "a"
+-- <interactive>:5:16: error:
+--     • Couldn't match type ‘'Global’ with ‘'Label’
+--       Expected: Ident 'Label
+--         Actual: Ident 'Global
+--     • In the second argument of ‘($)’, namely ‘Ident @'Global "a"’
+--       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, Binary, NFData, Hashable)
 
+instance Pretty (Ident 'AggregateTy) where
+  pretty (Ident raw) = pretty ':' <> pretty (TS.toText raw)
+instance Pretty (Ident 'Global) where
+  pretty (Ident raw) = pretty '$' <> pretty (TS.toText raw)
+instance Pretty (Ident 'Temporary) where
+  pretty (Ident raw) = pretty '%' <> pretty (TS.toText raw)
+instance Pretty (Ident 'Label) where
+  pretty (Ident raw) = pretty '@' <> pretty (TS.toText raw)
+
 -- * Types
 ----------
 
 data BaseTy = Word | Long | Single | Double
   deriving (Show, Eq)
 
+instance Pretty BaseTy where
+  pretty Word   = pretty 'w'
+  pretty Long   = pretty 'l'
+  pretty Single = pretty 's'
+  pretty Double = pretty 'd'
+
 data ExtTy = BaseTy BaseTy | Byte | HalfWord
   deriving (Show, Eq)
 
+instance Pretty ExtTy where
+  pretty (BaseTy baseTy) = pretty baseTy
+  pretty Byte = pretty 'b'
+  pretty HalfWord = pretty 'h'
+
 -- * Constants
 --------------
 
@@ -50,6 +90,13 @@ data Const
   | CGlobal (Ident 'Global)
   deriving (Show, Eq)
 
+instance Pretty Const where
+  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
+
 -- * Linkage
 ------------
 
@@ -58,6 +105,12 @@ data Linkage
   | Section ShortText (Maybe Text)
   deriving (Show, Eq)
 
+instance Pretty Linkage where
+  pretty Export = "export"
+  pretty (Section secName Nothing) = "section" <+> pretty (TS.toText secName)
+  pretty (Section secName (Just secFlags)) =
+    "section" <+> pretty (TS.toText secName) <+> pretty secFlags
+
 -- * Definitions
 ----------------
 
@@ -73,11 +126,27 @@ data Typedef
   | Opaque (Ident 'AggregateTy) Alignment Size
   deriving (Show, Eq)
 
+instance Pretty Typedef where
+  pretty (Typedef ident alignment def) =
+    "type" <+> pretty ident <+> equals
+    <> maybe mempty (\x -> space <> pretty x) alignment
+    <+> encloseSep lbrace rbrace (comma <> space) (prettyItem <$> def)
+    where
+      prettyItem (subTy, Nothing    ) = pretty subTy
+      prettyItem (subTy, Just amount) = pretty subTy <+> pretty amount
+  pretty (Opaque ident alignment size) =
+    "type" <+> pretty ident <+> equals
+    <+> "align" <+> pretty alignment <+> braces (pretty size)
+
 data SubTy
-  = SubExtTy
+  = SubExtTy ExtTy
   | SubAggregateTy (Ident 'AggregateTy)
   deriving (Show, Eq)
 
+instance Pretty SubTy where
+  pretty (SubExtTy extTy) = pretty extTy
+  pretty (SubAggregateTy ident) = pretty ident
+
 -- ** Data
 ----------
 
@@ -120,6 +189,11 @@ data Val
   | ValGlobal (Ident 'Global)
   deriving (Show, Eq)
 
+instance Pretty Val where
+  pretty (ValConst c) = pretty c
+  pretty (ValTemporary ident) = pretty ident
+  pretty (ValGlobal ident) = pretty ident
+
 data Block = Block (Ident 'Label) [Phi] [Inst] Jump
   deriving (Show, Eq)
 
@@ -129,6 +203,14 @@ data Jump
   | Ret (Maybe Val)
   deriving (Show, Eq)
 
+instance Pretty Jump where
+  pretty (Jmp ident) = "jmp" <+> pretty ident
+  pretty (Jnz val label1 label2) =
+    "jnz" <+> pretty val <> comma
+    <+> pretty label1 <> comma
+    <+> pretty label2
+  pretty (Ret val) = "ret" <+> pretty val
+
 -- * Instructions
 -----------------
 

test/Main.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExistentialQuantification #-}
+module Main (main) where
+
+import Language.QBE
+
+import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty.Silver (goldenVsAction)
+import System.FilePath ((</>), (<.>))
+import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
+import Prettyprinter.Render.Text (renderStrict)
+
+
+data P = forall a. Pretty a => P a
+instance Pretty P where
+  pretty (P x) = pretty x
+
+main :: IO ()
+main = defaultMain goldenTests
+
+goldenTests :: TestTree
+goldenTests = testGroup "golden tests"
+  [ t "ident"
+      [ P $ Ident @'AggregateTy "aggregateTy"
+      , P $ Ident @'Global "global"
+      , P $ Ident @'Temporary "temporary"
+      , P $ Ident @'Label "label"
+      ]
+  , t "type" ([Word, Long, Single, Double], [BaseTy Word, Byte, HalfWord])
+  , t "const"
+      [ CInt True 1
+      , CInt False 2
+      , CSingle 0.1
+      , CDouble (-0.2)
+      , CGlobal $ Ident "global"
+      ]
+  , t "linkage" (Export, Section "secName" Nothing, Section "secName" $ Just "flag1 flag2")
+  , t "typedef" $ Typedef (Ident "t") (Just 8)
+      [ (SubExtTy HalfWord, Just 16)
+      , (SubAggregateTy (Ident "t1"), Nothing)
+      ]
+  , t "opaque" $ Opaque (Ident "t") 8 16
+  , t "val" [ValConst (CInt False 0), ValTemporary $ Ident "temporary", ValGlobal $ Ident "global"]
+  , t "jmp" $ Jmp $ Ident "target"
+  , t "jnz" $ Jnz (ValConst $ CInt False 0) (Ident "target1") (Ident "target2")
+  , t "ret" $ Ret $ Just $ ValTemporary $ Ident "x"
+  ]
+  where
+    t name value = goldenVsAction
+      name
+      ("golden" </> name <.> "qbe")
+      (pure $ pretty value)
+      (renderStrict . layoutPretty defaultLayoutOptions)