syntax: Pretty instance for ExprError (#1274)

Author: langston-barrett

crucible-syntax/src/Lang/Crucible/Syntax/Atoms.hs

@@ -1,4 +1,7 @@
-{-# LANGUAGE LambdaCase, OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings#-}
+
 -- | Atoms used by the Crucible CFG concrete syntax.
 module Lang.Crucible.Syntax.Atoms
   (
@@ -24,20 +27,21 @@ import qualified Data.Text as T
 
 import Lang.Crucible.Syntax.SExpr
 import Numeric
+import qualified Prettyprinter as PP
 
 import Text.Megaparsec as MP hiding (many, some)
 import Text.Megaparsec.Char
 
 -- | The name of an atom (non-keyword identifier)
-newtype AtomName = AtomName Text deriving (Eq, Ord, Show)
+newtype AtomName = AtomName Text deriving (Eq, Ord, PP.Pretty, Show)
 -- | The name of a label (identifier followed by colon)
-newtype LabelName = LabelName Text deriving (Eq, Ord, Show)
+newtype LabelName = LabelName Text deriving (Eq, Ord, PP.Pretty, Show)
 -- | The name of a register (dollar sign followed by identifier)
-newtype RegName = RegName Text deriving (Eq, Ord, Show)
+newtype RegName = RegName Text deriving (Eq, Ord, PP.Pretty, Show)
 -- | The name of a function (at-sign followed by identifier)
-newtype FunName = FunName Text deriving (Eq, Ord, Show)
+newtype FunName = FunName Text deriving (Eq, Ord, PP.Pretty, Show)
 -- | The name of a global variable (two dollar signs followed by identifier)
-newtype GlobalName = GlobalName Text deriving (Eq, Ord, Show)
+newtype GlobalName = GlobalName Text deriving (Eq, Ord, PP.Pretty, Show)
 
 -- | Individual language keywords (reserved identifiers)
 data Keyword = Defun | DefBlock | DefGlobal | Declare | Extern

crucible-syntax/src/Lang/Crucible/Syntax/Concrete.hs

@@ -87,6 +87,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Vector as V
 import Numeric.Natural
+import qualified Prettyprinter as PP
 
 import Lang.Crucible.Syntax.ExprParse hiding (SyntaxError)
 import qualified Lang.Crucible.Syntax.ExprParse as SP
@@ -160,6 +161,27 @@ instance Semigroup (ExprErr s) where
 instance Monoid (ExprErr s) where
   mempty = TrivialErr (OtherPos "mempty")
 
+instance PP.Pretty (ExprErr s) where
+  pretty =
+    \case
+      TrivialErr p ->
+        "Trivial error at" PP.<+> PP.viaShow p
+      Errs e1 e2 ->
+        PP.vcat ["Multiple errors:" , PP.pretty e1 , PP.pretty e2]
+      DuplicateAtom p a ->
+        PP.hsep ["Duplicate atom", backticks (PP.pretty a), "at", PP.viaShow p]
+      DuplicateLabel p l ->
+        PP.hsep ["Duplicate label", backticks (PP.pretty l), "at", PP.viaShow p]
+      EmptyBlock p ->
+        "Empty block at" PP.<+> PP.viaShow p
+      NotGlobal p _ast ->
+        "Expected a global at" PP.<+> PP.viaShow p
+      InvalidRegister p _ast ->
+        "Expected a register at" PP.<+> PP.viaShow p
+      SyntaxParseError err ->
+        PP.pretty (printSyntaxError err)
+    where backticks = PP.enclose "`" "`"
+
 -- | ParserHooks enables support for arbitrary syntax extensions by allowing
 -- users to supply their own parsers for types and syntax extensions.
 data ParserHooks ext = ParserHooks {