Add Pretty instance to AST, Error and Range

tools/lsp/squirrel/app/Main.hs

@@ -1,7 +1,10 @@
 
+import Data.Foldable (for_)
+
 import ParseTree
 import Parser
 import AST
+import PrettyPrint
 
 import System.Environment
 
@@ -9,4 +12,8 @@ main :: IO ()
 main = do
   [fin] <- getArgs
   toParseTree fin >>= print
-  runParser contract fin >>= print
+  (res, errs) <- runParser contract fin
+  print (pp res)
+  putStrLn ""
+  putStrLn "Errors:"
+  for_ errs (print . nest 2 . pp)

tools/lsp/squirrel/squirrel.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: f4f92cb29b0c7d516e57ceee58c9d82900fc41d82cf21f7aa033094288165072
+-- hash: 9aa7bb8abf29ee513a2033ae2b0ef8310107294ad348fa7510ec615a1b11c4ea
 
 name:           squirrel
 version:        0.0.0
@@ -14,6 +14,7 @@ library
   exposed-modules:
       AST
       AST.Parser
+      AST.Pretty
       AST.Types
       Parser
       ParseTree

tools/lsp/squirrel/src/AST/Parser.hs

@@ -60,9 +60,13 @@ binding = do
       stubbed "type" do
         field "type" type_
     consume "is"
-    expr <- stubbed "body" do
+    exp <- stubbed "body" do
-      field "locals" anything
+      field "expr" expr
-    return (Function info (recur == Just "recursive") name params ty expr)
+    return (Function info (recur == Just "recursive") name params ty exp)
+
+expr :: Parser (Expr Range)
+expr = do
+  fallback "expr"
 
 paramDecl :: Parser (VarDecl Range)
 paramDecl = do

tools/lsp/squirrel/src/AST/Pretty.hs

@@ -5,18 +5,98 @@ import AST.Types
 import PrettyPrint
 import Parser
 
--- instance Pretty (Contract i) where
+instance Pretty (Contract i) where
---   pp (Contract _ decls) =
+  pp = \case
---     hang "(* contract *)" 2 do
+    Contract _ decls ->
---       vcat $ map (($$ empty) . pp) decls
+      hang "(* contract *)" 2 do
+        vcat $ map (($$ empty) . pp) decls
 
---   pp (WrongContract err) =
+    WrongContract err ->
---     pp err
+      pp err
 
--- instance Pretty Error where
+instance Pretty (Declaration i) where
---   pp
+  pp = \case
+    ValueDecl _ binding -> pp binding
+    WrongDecl err       -> pp err
 
--- instance Pretty (Declaration i) where
+instance Pretty (Binding i) where
---   pp (
+  pp = \case
+    Irrefutable  _ pat expr -> error "irrefs in pascaligo?"
+    Function     _ isRec name params ty body ->
+      hang
+        ( fsep
+          [ if isRec then "recursive" else empty
+          , "function"
+          , pp name
+          , parens $ fsep $ punctuate "," $ map pp params
+          , ":"
+          , pp ty
+          , "is"
+          ]
+        )
+        2
+        (pp body)
+    WrongBinding err ->
+      pp err
 
--- wrap [l, r] a = hang (hang l 2 r) 0 r
+instance Pretty (VarDecl i) where
+  pp = \case
+    Decl _ mutability name ty -> fsep
+      [ pp mutability
+      , pp name
+      , ":"
+      , pp ty
+      ]
+    WrongVarDecl err ->
+      pp err
+
+instance Pretty (Mutable i) where
+  pp = \case
+    Mutable      _   -> "var"
+    Immutable    _   -> "const"
+    WrongMutable err -> pp err
+
+instance Pretty (Type i) where
+  pp = \case
+    TArrow    _ dom codom -> parens (pp dom <+> "->" <+> pp codom)
+    Record    _ fields    -> wrap ["record [", "]"] $ vcat $ map ppField fields
+    TVar      _ name      -> pp name
+    Sum       _ variants  -> vcat $ map ppCtor variants
+    Product   _ elements  -> fsep $ punctuate " *" $ map pp elements
+    TApply    _ f xs      -> pp f <> parens (fsep $ punctuate "," $ map pp xs)
+    WrongType   err       -> pp err
+    where
+      ppField (name, ty) = pp name <> ": " <> pp ty <> ";"
+      ppCtor  (ctor, fields) =
+        "|" <+> pp ctor <+> parens (fsep $ punctuate "," $ map pp fields)
+
+instance Pretty (Expr i) where
+  pp = \case
+    Let       _ decls body -> hang "let" 2 (vcat $ map pp decls)
+                           <> hang "in"  2 (pp body)
+    Apply     _ f xs       -> pp f <> parens (fsep $ punctuate "," $ map pp xs)
+    Constant  _ constant   -> pp constant
+    Ident     _ qname      -> pp qname
+    WrongExpr   err        -> pp err
+
+
+instance Pretty (Constant i) where
+  pp = \case
+    Int           _ c   -> int c
+    String        _ c   -> doubleQuotes (pp c)
+    Float         _ c   -> double c
+    Bytes         _ c   -> pp c
+    WrongConstant   err -> pp err
+
+instance Pretty (QualifiedName i) where
+  pp = \case
+    QualifiedName _ src path -> pp src <> cat (map (("." <>) . pp) path)
+    WrongQualifiedName err   -> pp err
+
+
+instance Pretty (Name i) where
+  pp = \case
+    Name      _ raw -> pp raw
+    WrongName err   -> pp err
+
+wrap [l, r] a = hang (hang l 2 r) 0 r

tools/lsp/squirrel/src/AST/Types.hs

@@ -32,7 +32,7 @@ instance Stubbed (Declaration info) where stub = WrongDecl
 
 data Binding info
   = Irrefutable  info (Pattern info) (Expr info)
-  | Function     info Bool (Name info) [VarDecl info] (Type info) TODO
+  | Function     info Bool (Name info) [VarDecl info] (Type info) (Expr info)
   | WrongBinding      Error
   deriving stock (Show)
 
@@ -67,7 +67,7 @@ instance Stubbed (Type info) where stub = WrongType
 
 data Expr info
   = Let       info [Declaration info] (Expr info)
-  | Apply     info (Expr info) (Expr info)
+  | Apply     info (Expr info) [Expr info]
   | Constant  info (Constant info)
   | Ident     info (QualifiedName info)
   | WrongExpr      Error
@@ -94,9 +94,11 @@ data Pattern info
 
 instance Stubbed (Pattern info) where stub = WrongPattern
 
-data QualifiedName info = QualifiedName
+data QualifiedName info
-  { source :: Name info
+  = QualifiedName
-  , path   :: [Name info]
+    { qnInfo   :: info
+    , qnSource :: Name info
+    , qnPath   :: [Name info]
     }
   | WrongQualifiedName Error
   deriving stock (Show)

tools/lsp/squirrel/src/Parser.hs

@@ -15,6 +15,7 @@ import Data.ByteString (ByteString)
 
 import ParseTree
 import Range
+import PrettyPrint
 
 import Debug.Trace
 
@@ -26,6 +27,10 @@ data Error
     }
   deriving stock (Show)
 
+instance Pretty Error where
+  pp (Expected msg found r) = "<" <> pp msg <> pp r <> ": " <> pp found <> ">"
+
+
 newtype Parser a = Parser
   { unParser
       :: WriterT [Error]

tools/lsp/squirrel/src/PrettyPrint.hs

@@ -5,7 +5,12 @@ module PrettyPrint
   )
   where
 
+import Data.Text
+
 import Text.PrettyPrint hiding ((<>))
 
 class Pretty p where
   pp :: p -> Doc
+
+instance Pretty Text where
+  pp = text . unpack