Finish pretty-printer and Hedgehog tests

lamagraph-compiler/lamagraph-compiler.cabal

@@ -31,6 +31,7 @@ library
       Lamagraph.Compiler.Parser.LexerUtils
       Lamagraph.Compiler.Parser.SrcLoc
       Lamagraph.Compiler.PrettyAST
+      Lamagraph.Compiler.PrettyLML
       Lamagraph.Compiler.Syntax
       Lamagraph.Compiler.Syntax.Decl
       Lamagraph.Compiler.Syntax.Expr
@@ -89,8 +90,11 @@ test-suite lamagraph-compiler-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Lamagraph.Compiler.Parser.GoldenCommon
       Lamagraph.Compiler.Parser.LexerTest
-      Lamagraph.Compiler.ParserGoldenTest
+      Lamagraph.Compiler.Parser.ParserRoundtrip
+      Lamagraph.Compiler.Parser.PrettyASTGolden
+      Lamagraph.Compiler.Parser.PrettyLmlGolden
       Paths_lamagraph_compiler
   hs-source-dirs:
       test
@@ -106,12 +110,13 @@ test-suite lamagraph-compiler-test
     , base >=4.7 && <5
     , extra
     , filepath
+    , hedgehog
     , lamagraph-compiler
     , lens
-    , pretty-simple
     , prettyprinter
     , relude
     , tasty
     , tasty-golden
+    , tasty-hedgehog
     , tasty-hunit
   default-language: GHC2021

lamagraph-compiler/package.yaml

@@ -78,4 +78,5 @@ tests:
       - tasty
       - tasty-hunit
       - tasty-golden
-      - pretty-simple
+      - tasty-hedgehog
+      - hedgehog

lamagraph-compiler/src/Lamagraph/Compiler/Extension.hs

@@ -3,8 +3,6 @@
 
 module Lamagraph.Compiler.Extension (Pass (..), LmlcPass (..), LmlcPs) where
 
--- import Relude
-
 import Lamagraph.Compiler.Parser.SrcLoc
 import Lamagraph.Compiler.Syntax
 

lamagraph-compiler/src/Lamagraph/Compiler/Parser.y

@@ -168,23 +168,52 @@ typeconstr_name :: { XLocated LmlcPs Text }
 -- Qualified names --
 ---------------------
 module_pathT :: { NonEmpty LToken }
-  : mkIdent(module_pathT, capitalized_ident) { $1 }
+  : mkIdentRev(module_pathT, capitalized_ident) { $1 }
+
+value_nameT :: { LToken }
+  : lowercase_ident { $1 }
+  | '(' operator_nameT ')' { sLL $1 $3 $ unLoc $2 }
+
+operator_nameT :: { LToken }
+  : prefix_symbol { $1 }
+  | infix_opT { $1 }
+
+infix_opT :: { LToken }
+  : infix_symbol0 { $1 }
+  | infix_symbol1 { $1 }
+  | infix_symbol2 { $1 }
+  | infix_symbol3 { $1 }
+  | infix_symbol4 { $1 }
+  | '*' { $1 }
+  | '+' { $1 }
+  | '-' { $1 }
+  | '=' { $1 }
+  | '||' { $1 }
+  | '&&' { $1 }
+  | 'mod' { $1 }
+  | 'land' { $1 }
+  | 'lor' { $1 }
+  | 'lxor' { $1 }
+  | 'lsl' { $1 }
+  | 'lsr' { $1 }
+  | 'asr' { $1 }
 
 value_path :: { LLongident LmlcPs }
-  : mkIdent(module_pathT, lowercase_ident) { sLNE $1 $ getLongident $1 }
+  : mkIdentRev(module_pathT, value_nameT) { sLNE $1 $ getLongident (NE.reverse $1) }
+  -- | mkIdentRev(module_pathT, ) { sLNE $1 $ getLongident (NE.reverse $1) }
 
 constr :: { LLongident LmlcPs }
-  : mkIdent(module_pathT, capitalized_ident) { sLNE $1 $ getLongident $1 }
+  : mkIdentRev(module_pathT, capitalized_ident) { sLNE $1 $ getLongident (NE.reverse $1) }
   | '[' ']' { sLL $1 $2 nilConstruct }
   | '(' ')' { sLL $1 $2 unitConstruct }
   | 'true' { sL1 $1 $ (mkLongident . pure) "true" }
   | 'false' { sL1 $1 $ (mkLongident . pure) "false" }
 
 typeconstr :: { LLongident LmlcPs }
-  : mkIdent(module_pathT, lowercase_ident) { sLNE $1 $ getLongident $1 }
+  : mkIdentRev(module_pathT, lowercase_ident) { sLNE $1 $ getLongident (NE.reverse $1) }
 
 module_path :: { LLongident LmlcPs }
-  : module_pathT { sLNE $1 $ getLongident $1 }
+  : module_pathT { sLNE $1 $ getLongident (NE.reverse $1) }
 
 ----------------------
 -- Type expressions --

lamagraph-compiler/src/Lamagraph/Compiler/Parser/Lexer.x

@@ -49,7 +49,11 @@ $operator_char = [\! \$ \% & \* \+ \. \/ \: \< \= \> \? \@ \^ \| \~]
 -- Identifiers
 @ident_tail = ( $letter | $digit | \_ | \' )*
 @capitalized_ident = $capital_letter @ident_tail
-@lowercase_ident = ( $lowercase_letter | \_ ) @ident_tail
+-- @lowercase_ident = ( $lowercase_letter | \_ ) @ident_tail
+@lowercase_ident = (
+  ( $lowercase_letter @ident_tail)
+  | ( \_ ( $letter | $digit ) @ident_tail )
+)
 
 -- Integer literals
 @integer_literal = \-? $digit ( $digit | \_ )*

lamagraph-compiler/src/Lamagraph/Compiler/Parser/SrcLoc.hs

@@ -119,9 +119,9 @@ makeLenses ''RealSrcSpan
 A 'SrcSpan' represents either "good" portion of a file
 or a description of a "bad" span.
 -}
-data SrcSpan = RealSrcSpan RealSrcSpan | UnhelpfulSpan UnhelpfulSpanReason deriving (Show)
+data SrcSpan = RealSrcSpan RealSrcSpan | UnhelpfulSpan UnhelpfulSpanReason deriving (Show, Eq)
 
-data UnhelpfulSpanReason = UnhelpfulGenerated | UnhelpfulOther Text deriving (Show)
+data UnhelpfulSpanReason = UnhelpfulGenerated | UnhelpfulOther Text deriving (Show, Eq)
 
 generatedSrcSpan :: SrcSpan
 generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated
@@ -173,6 +173,13 @@ combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
 -- | 'SrcSpan's will be attached to nearly everything, let's create a type for attaching.
 data GenLocated l e = L l e deriving (Show)
 
+{- | This is very specific instance for 'Eq'.
+It doesn't compare locations, only contents.
+-}
+instance (Eq e) => Eq (GenLocated l e) where
+  (==) :: GenLocated l e -> GenLocated l e -> Bool
+  (L _ a) == (L _ b) = a == b
+
 makePrisms ''GenLocated
 
 type Located = GenLocated SrcSpan

lamagraph-compiler/src/Lamagraph/Compiler/PrettyAST.hs

@@ -119,7 +119,7 @@ instance Pretty (LmlLit (LmlcPass pass)) where
 
 instance Pretty Longident where
   pretty :: Longident -> Doc ann
-  pretty (Longident indents) = dquotes $ hsep $ punctuate comma (map pretty (toList indents))
+  pretty (Longident idents) = dquotes $ hsep $ punctuate comma (map pretty (toList idents))
 
 instance Pretty (LmlPat (LmlcPass pass)) where
   pretty :: LmlPat (LmlcPass pass) -> Doc ann

lamagraph-compiler/src/Lamagraph/Compiler/PrettyLML.hs

@@ -0,0 +1,149 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- | Orphan instances for pretty-printing LamagraphML
+module Lamagraph.Compiler.PrettyLML () where
+
+import Relude
+
+import Data.Text qualified as T
+import Prettyprinter
+
+import Lamagraph.Compiler.Extension
+import Lamagraph.Compiler.Parser.SrcLoc
+import Lamagraph.Compiler.Syntax
+
+prettyADTVar :: LLmlType (LmlcPass pass) -> Doc ann
+prettyADTVar (L _ (LmlTyVar _ varName)) = "'" <> pretty varName
+prettyADTVar _ = error "Internal pretty-printer error: cannot have complex types in type parameters"
+
+prettyADTVars :: [LLmlType (LmlcPass pass)] -> Doc ann
+prettyADTVars [] = emptyDoc
+prettyADTVars [var] = prettyADTVar var <> space
+prettyADTVars vars = parens (fillSep $ punctuate comma (map prettyADTVar vars)) <> space
+
+prettyChar :: Char -> Doc ann
+prettyChar '\\' = "\\\\"
+prettyChar '\"' = "\\\""
+prettyChar '\'' = "\\\'"
+prettyChar '\n' = "\\\n"
+prettyChar c
+  | c `elem` ['\32' .. '\127'] = pretty c
+  | otherwise = error "Internal pretty-printer error: trying to print unsupported character"
+
+prettyString :: Text -> Doc ann
+prettyString str = mconcat $ map prettyChar (toString str)
+
+instance (Pretty a) => Pretty (Located a) where
+  pretty :: Located a -> Doc ann
+  pretty (L _ a) = pretty a
+
+instance Pretty RecFlag where
+  pretty :: RecFlag -> Doc ann
+  pretty Recursive = "rec" <> space
+  pretty NonRecursive = emptyDoc
+
+instance Pretty (LmlDecl (LmlcPass pass)) where
+  pretty :: LmlDecl (LmlcPass pass) -> Doc ann
+  pretty (OpenD _ decl) = "open" <+> pretty decl
+  pretty (ValD _ recFlag binds) = "let" <+> pretty recFlag <> concatWith (surround (hardline <> "and" <> hardline)) (map pretty (toList binds))
+  pretty (TyD _ decls) = "type" <+> concatWith (surround (hardline <> "and" <> hardline)) (map pretty (toList decls))
+
+instance Pretty (OpenDecl (LmlcPass pass)) where
+  pretty :: OpenDecl (LmlcPass pass) -> Doc ann
+  pretty (OpenDecl _ ident) = pretty ident
+
+instance Pretty (TyDecl (LmlcPass pass)) where
+  pretty :: TyDecl (LmlcPass pass) -> Doc ann
+  pretty (AliasDecl _ name vars ty) = prettyADTVars vars <> pretty name <+> "=" <> softline <> pretty ty
+  pretty (DataDecl _ name vars []) = prettyADTVars vars <> pretty name
+  pretty (DataDecl _ name vars constrs) =
+    prettyADTVars vars
+      <> pretty name <+> align ("=" <+> encloseSep emptyDoc emptyDoc (flatAlt "| " " | ") (map pretty constrs))
+
+instance Pretty (ConDecl (LmlcPass pass)) where
+  pretty :: ConDecl (LmlcPass pass) -> Doc ann
+  pretty (ConDecl _ (L _ "::") args) = "(::)" <+> "of" <+> concatWith (surround " * ") (map pretty args)
+  pretty (ConDecl _ name args) =
+    pretty name <> case args of
+      [] -> emptyDoc
+      _ -> space <> "of" <+> concatWith (surround " * ") (map pretty args)
+
+instance Pretty (LmlExpr (LmlcPass pass)) where
+  pretty :: LmlExpr (LmlcPass pass) -> Doc ann
+  pretty (LmlExprIdent _ ident) = pretty ident
+  pretty (LmlExprConstant _ constant) = pretty constant
+  pretty (LmlExprLet _ recFlag binds expr) =
+    "let" <+> pretty recFlag
+      <> concatWith (surround (hardline <> "and" <> hardline)) (map pretty (toList binds)) <+> "in" <+> pretty expr
+  pretty (LmlExprFunction _ pat expr) = "fun" <+> pretty pat <+> "->" <+> pretty expr
+  pretty (LmlExprApply _ expr exprs) = pretty expr <+> hsep (map (parens . pretty) (toList exprs))
+  pretty (LmlExprMatch _ expr cases) =
+    parens $
+      align
+        ("match" <+> pretty expr <+> "with" <+> encloseSep emptyDoc emptyDoc (flatAlt "| " " | ") (map pretty (toList cases)))
+  pretty (LmlExprTuple _ expr exprs) = parens (fillSep $ punctuate comma (map (parens . pretty) (expr : toList exprs)))
+  pretty (LmlExprConstruct _ (L _ (Longident ("::" :| []))) (Just (L _ (LmlExprTuple _ hd tl)))) = parens (pretty hd <+> "::" <+> pretty (head tl))
+  pretty (LmlExprConstruct _ constr Nothing) = pretty constr
+  pretty (LmlExprConstruct _ constr (Just expr)) = parens (pretty constr <+> parens (pretty expr))
+  pretty (LmlExprIfThenElse _ cond t f) = "if" <+> pretty cond <+> "then" <+> pretty t <+> "else" <+> pretty f
+  pretty (LmlExprConstraint _ expr ty) = parens (pretty expr <+> ":" <+> pretty ty)
+
+instance Pretty (LmlBind (LmlcPass pass)) where
+  pretty :: LmlBind (LmlcPass pass) -> Doc ann
+  pretty (LmlBind _ pat expr) = pretty pat <+> "=" <> softline <> pretty expr
+
+instance Pretty (LmlCase (LmlcPass pass)) where
+  pretty :: LmlCase (LmlcPass pass) -> Doc ann
+  pretty (LmlCase _ pat Nothing expr) = pretty pat <+> "->" <+> pretty expr
+  pretty (LmlCase _ pat (Just constraint) expr) = pretty pat <+> "when" <+> pretty constraint <+> "->" <+> pretty expr
+
+instance Pretty (LmlLit (LmlcPass pass)) where
+  pretty :: LmlLit (LmlcPass pass) -> Doc ann
+  pretty (LmlInt _ int) = pretty int
+  pretty (LmlInt32 _ int32) = pretty int32 <> "l"
+  pretty (LmlUInt32 _ uint32) = pretty uint32 <> "ul"
+  pretty (LmlInt64 _ int64) = pretty int64 <> "L"
+  pretty (LmlUInt64 _ uint64) = pretty uint64 <> "UL"
+  pretty (LmlChar _ char) = squotes $ prettyChar char
+  pretty (LmlString _ str) = dquotes $ prettyString str
+
+instance Pretty Longident where
+  pretty :: Longident -> Doc ann
+  pretty (Longident ident) = if res then prettyInit <> parens (space <> pretty func <> space) else prettyInit <> pretty func
+   where
+    func = last ident
+    initList = init ident
+    prettyInit = if null initList then emptyDoc else concatWith (surround dot) (map pretty initList) <> dot
+    prefixes = ["*", "/", "%", "+", "-", "@", "^", "=", "<", ">", "|", "&", "$", "!", "?", "~"]
+    equal = ["lor", "lxor", "mod", "land", "lsl", "lsr", "asr"]
+    startsWithB = map (`T.isPrefixOf` func) prefixes
+    equalsB = map (func ==) equal
+    res = or startsWithB || or equalsB
+
+instance Pretty (LmlPat (LmlcPass pass)) where
+  pretty :: LmlPat (LmlcPass pass) -> Doc ann
+  pretty (LmlPatAny _) = "_"
+  pretty (LmlPatVar _ (L _ var)) = pretty $ mkLongident (pure var)
+  pretty (LmlPatConstant _ constant) = pretty constant
+  pretty (LmlPatTuple _ pat pats) = parens $ fillSep (punctuate comma (map pretty (pat : toList pats)))
+  pretty (LmlPatConstruct _ (L _ (Longident ("::" :| []))) (Just (L _ (LmlPatTuple _ hd tl)))) = parens (pretty hd <+> "::" <+> pretty (head tl))
+  pretty (LmlPatConstruct _ constr Nothing) = pretty constr
+  pretty (LmlPatConstruct _ constr (Just pat)) = parens (pretty constr <+> parens (pretty pat))
+  pretty (LmlPatOr _ pat1 pat2) = parens (pretty pat1 <+> "|" <+> pretty pat2)
+  pretty (LmlPatConstraint _ pat ty) = parens (pretty pat <+> ":" <+> pretty ty)
+
+instance Pretty (LmlType (LmlcPass pass)) where
+  pretty :: LmlType (LmlcPass pass) -> Doc ann
+  pretty (LmlTyVar _ var) = "'" <> pretty var
+  pretty (LmlTyArrow _ ty1 ty2) = parens (pretty ty1 <+> "->" <> softline <> pretty ty2)
+  pretty (LmlTyTuple _ ty tys) = parens $ concatWith (surround " * ") (map pretty (ty : toList tys))
+  pretty (LmlTyConstr _ constr []) = pretty constr
+  pretty (LmlTyConstr _ constr [ty@(L _ (LmlTyArrow{}))]) = parens (pretty ty) <+> pretty constr
+  pretty (LmlTyConstr _ constr [ty]) = pretty ty <+> pretty constr
+  pretty (LmlTyConstr _ constr tys) = parens (fillSep $ punctuate comma (map pretty tys)) <+> pretty constr
+
+instance Pretty (LmlModule (LmlcPass pass)) where
+  pretty :: LmlModule (LmlcPass pass) -> Doc ann
+  pretty (LmlModule _ name decls) = concatWith (surround (hardline <> hardline)) $ case name of
+    Nothing -> map pretty decls
+    Just moduleName -> ("module" <+> pretty moduleName) : map pretty decls

lamagraph-compiler/src/Lamagraph/Compiler/Syntax.hs

@@ -362,3 +362,4 @@ type ForallLmlModule (tc :: Type -> Constraint) pass =
   (tc (XCModule pass), tc (LLongident pass), tc (LLmlDecl pass), tc (XXModule pass))
 
 deriving instance (ForallLmlModule Show pass) => Show (LmlModule pass)
+deriving instance (ForallLmlModule Eq pass) => Eq (LmlModule pass)

lamagraph-compiler/src/Lamagraph/Compiler/Syntax/Decl.hs

@@ -44,6 +44,7 @@ type ForallLmlDecl (tc :: Type -> Constraint) pass =
   )
 
 deriving instance (ForallLmlDecl Show pass) => Show (LmlDecl pass)
+deriving instance (ForallLmlDecl Eq pass) => Eq (LmlDecl pass)
 
 -- | Located open declaration
 type LOpenDecl pass = XLocated pass (OpenDecl pass)
@@ -60,6 +61,7 @@ type ForallOpenDecl (tc :: Type -> Constraint) pass =
   (tc (XOpenDecl pass), tc (XXOpenDecl pass), tc (LLongident pass))
 
 deriving instance (ForallOpenDecl Show pass) => Show (OpenDecl pass)
+deriving instance (ForallOpenDecl Eq pass) => Eq (OpenDecl pass)
 
 -- | Located type declaration
 type LTyDecl pass = XLocated pass (TyDecl pass)
@@ -82,6 +84,7 @@ type ForallTyDecl (tc :: Type -> Constraint) pass =
   )
 
 deriving instance (ForallTyDecl Show pass) => Show (TyDecl pass)
+deriving instance (ForallTyDecl Eq pass) => Eq (TyDecl pass)
 
 -- | Located ADT constructor declaration
 type LConDecl pass = XLocated pass (ConDecl pass)
@@ -102,3 +105,4 @@ type ForallConDecl (tc :: Type -> Constraint) pass =
   (tc (XConDecl pass), tc (XLocated pass Text), tc (LLmlType pass), tc (XXConDecl pass))
 
 deriving instance (ForallConDecl Show pass) => Show (ConDecl pass)
+deriving instance (ForallConDecl Eq pass) => Eq (ConDecl pass)

lamagraph-compiler/src/Lamagraph/Compiler/Syntax/Expr.hs

@@ -23,7 +23,7 @@ import Lamagraph.Compiler.Syntax.Pat
 import Lamagraph.Compiler.Syntax.Type
 
 -- | Flag for recursive let-bindings
-data RecFlag = Recursive | NonRecursive deriving (Show)
+data RecFlag = Recursive | NonRecursive deriving (Show, Eq)
 
 -- | Located 'LmlExpr'
 type LLmlExpr pass = XLocated pass (LmlExpr pass)
@@ -81,6 +81,7 @@ type ForallLmlExpr (tc :: Type -> Constraint) pass =
   )
 
 deriving instance (ForallLmlExpr Show pass) => Show (LmlExpr pass)
+deriving instance (ForallLmlExpr Eq pass) => Eq (LmlExpr pass)
 
 -- | Located let binder
 type LLmlBind pass = XLocated pass (LmlBind pass)
@@ -97,6 +98,7 @@ type ForallLmlBind (tc :: Type -> Constraint) pass =
   (tc (XLmlBind pass), tc (LLmlPat pass), tc (LLmlExpr pass), tc (XXBind pass))
 
 deriving instance (ForallLmlBind Show pass) => Show (LmlBind pass)
+deriving instance (ForallLmlBind Eq pass) => Eq (LmlBind pass)
 
 -- | Located case binder type
 type LLmlCase pass = XLocated pass (LmlCase pass)
@@ -110,3 +112,4 @@ type ForallLmlCase (tc :: Type -> Constraint) pass =
   (tc (XLmlCase pass), tc (LLmlPat pass), tc (LLmlExpr pass), tc (XXCase pass))
 
 deriving instance (ForallLmlCase Show pass) => Show (LmlCase pass)
+deriving instance (ForallLmlCase Eq pass) => Eq (LmlCase pass)

lamagraph-compiler/src/Lamagraph/Compiler/Syntax/Extension.hs

@@ -10,14 +10,14 @@ import Relude
 {- | Type to serve as a placeholder for TTG extension points, which can be constructed,
 but aren't used to hold something more useful.
 -}
-data NoExtField = NoExtField deriving (Show)
+data NoExtField = NoExtField deriving (Show, Eq)
 
 -- | Is used to construct a term.
 noExtField :: NoExtField
 noExtField = NoExtField
 
 -- | Isomorphic to 'Void'.
-data DataConCantHappen deriving (Show)
+data DataConCantHappen deriving (Show, Eq)
 
 dataConCanHappen :: DataConCantHappen -> a
 dataConCanHappen x = case x of {}

lamagraph-compiler/src/Lamagraph/Compiler/Syntax/Lit.hs

@@ -30,3 +30,4 @@ type ForallLmlLit (tc :: Type -> Constraint) pass =
   )
 
 deriving instance (ForallLmlLit Show pass) => Show (LmlLit pass)
+deriving instance (ForallLmlLit Eq pass) => Eq (LmlLit pass)