balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Improve pretty-printer

Browse Source
This commit is contained in:
Kirill Andreev 2020-05-08 22:07:53 +04:00
parent 19e1018620
commit 020b3ba334
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
3 changed files with 88 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
tools/lsp/squirrel/src/AST/Types.hs
View File

@ -209,6 +209,7 @@ data Name info = Name
, raw :: Text , raw :: Text
} }
| WrongName Error | WrongName Error
deriving (Show) via PP (Name info)
instance Stubbed (Name info) where stub = WrongName instance Stubbed (Name info) where stub = WrongName
@ -216,17 +217,12 @@ c :: HasComments i => i -> Doc -> Doc
c i d = c i d =
case getComments i of case getComments i of
[] -> d [] -> d
cc -> vcat (map pp cc) $$ d cc -> block (map Text.init cc) $$ d
instance Show (Name i) where
show = \case
Name i raw -> Text.unpack raw
WrongName r -> "(Name? " ++ show r ++ ")"
instance HasComments i => Pretty (Contract i) where instance HasComments i => Pretty (Contract i) where
pp = \case pp = \case
Contract i decls -> c i $ Contract i decls -> c i $
vcat $ punctuate "\n" $ map (($$ empty) . pp) decls sparseBlock decls
WrongContract err -> WrongContract err ->
pp err pp err
@ -234,7 +230,7 @@ instance HasComments i => Pretty (Contract i) where
instance HasComments i => Pretty (Declaration i) where instance HasComments i => Pretty (Declaration i) where
pp = \case pp = \case
ValueDecl i binding -> c i $ pp binding ValueDecl i binding -> c i $ pp binding
TypeDecl i n ty -> c i $ hang ("type" <+> pp n <+> "=") 2 (pp ty) TypeDecl i n ty -> c i $ "type" <+> pp n <+> "=" `indent` pp ty
Action i e -> c i $ pp e Action i e -> c i $ pp e
Include i f -> c i $ "#include" <+> pp f Include i f -> c i $ "#include" <+> pp f
WrongDecl err -> pp err WrongDecl err -> pp err
@ -243,40 +239,27 @@ instance HasComments i => Pretty (Binding i) where
pp = \case pp = \case
Irrefutable i pat expr -> error "irrefs in pascaligo?" Irrefutable i pat expr -> error "irrefs in pascaligo?"
Function i isRec name params ty body -> Function i isRec name params ty body ->
c i $ hang c i $
( fsep (
[ if isRec then "recursive" else empty (
, "function" ( (if isRec then "recursive" else empty)
, pp name <+> "function"
, tuple params <+> pp name
, ":" )
, pp ty `indent` tuple params
, "is" )
] `indent` (":" <+> pp ty <+> "is")
) )
2 `indent` pp body
(pp body) Var i name ty value -> c i $ "var" <+> pp name <+> ":" <+> pp ty <+> ":=" `indent` pp value
Var i name ty value -> Const i name ty body -> c i $ "const" <+> pp name <+> ":" <+> pp ty <+> "=" `indent` pp body
c i $ hang
("var" <+> pp name <+> ":" <+> pp ty <+> ":=")
2
(pp value)
Const i name ty body ->
c i $ hang
("const" <+> pp name <+> ":" <+> pp ty <+> "=")
2
(pp body)
WrongBinding err -> WrongBinding err ->
pp err pp err
instance HasComments i => Pretty (VarDecl i) where instance HasComments i => Pretty (VarDecl i) where
pp = \case pp = \case
Decl i mutability name ty -> c i $ fsep Decl i mutability name ty -> c i $
[ pp mutability pp mutability <+> pp name <+> ":" `indent` pp ty
, pp name
, ":"
, pp ty
]
WrongVarDecl err -> WrongVarDecl err ->
pp err pp err
@ -288,74 +271,74 @@ instance HasComments i => Pretty (Mutable i) where
instance HasComments i => Pretty (Type i) where instance HasComments i => Pretty (Type i) where
pp = \case pp = \case
TArrow i dom codom -> c i $ parens (pp dom <+> "->" <+> pp codom) TArrow i dom codom -> c i $ parens (pp dom `indent` "->" <+> pp codom)
TRecord i fields -> c i $ "record [" <> (vcat $ map pp fields) <> "]" TRecord i fields -> c i $ "record" <+> list fields
TVar i name -> c i $ pp name TVar i name -> c i $ pp name
TSum i variants -> c i $ vcat $ map pp variants TSum i variants -> c i $ block variants
TProduct i elements -> c i $ fsep $ punctuate " *" $ map pp elements TProduct i elements -> c i $ train " *" elements
TApply i f xs -> c i $ pp f <> parens (fsep $ punctuate "," $ map pp xs) TApply i f xs -> c i $ pp f <> tuple xs
WrongType err -> pp err WrongType err -> pp err
where where
ppField (name, ty) = pp name <> ": " <> pp ty <> ";" ppField (name, ty) = pp name <> ": " <> pp ty <> ";"
instance HasComments i => Pretty (Variant i) where instance HasComments i => Pretty (Variant i) where
pp = \case pp = \case
Variant i ctor (Just ty) -> c i $ hang ("|" <+> pp ctor <+> "of") 2 (pp ty) Variant i ctor (Just ty) -> c i $ "|" <+> pp ctor <+> "of" `indent` pp ty
Variant i ctor _ -> c i $ "|" <+> pp ctor Variant i ctor _ -> c i $ "|" <+> pp ctor
WrongVariant err -> pp err WrongVariant err -> pp err
-- My eyes. -- My eyes.
instance HasComments i => Pretty (Expr i) where instance HasComments i => Pretty (Expr i) where
pp = \case pp = \case
Let i decls body -> c i $ "block {" $$ (nest 2 $ vcat $ punctuate "\n" $ map pp decls) $$ "}" $$ "with" $$ nest 2 (pp body) Let i decls body -> c i $ "block {" `indent` sparseBlock decls `above` "}" <+> "with" `indent` pp body
Apply i f xs -> c i $ pp f <+> tuple xs Apply i f xs -> c i $ pp f <+> tuple xs
Constant i constant -> c i $ pp constant Constant i constant -> c i $ pp constant
Ident i qname -> c i $ pp qname Ident i qname -> c i $ pp qname
BinOp i l o r -> c i $ parens (pp l <+> pp o <+> pp r) BinOp i l o r -> c i $ parens (pp l <+> pp o <+> pp r)
UnOp i o r -> c i $ parens (pp o <+> pp r) UnOp i o r -> c i $ parens (pp o <+> pp r)
Record i az -> c i $ "record [" <> (fsep $ punctuate ";" $ map pp az) <> "]" Record i az -> c i $ "record" <+> list az
If i b t e -> c i $ fsep ["if" <+> pp b, hang "then" 2 $ pp t, hang "else" 2 $ pp e] If i b t e -> c i $ fsep ["if" `indent` pp b, "then" `indent` pp t, "else" `indent` pp e]
Assign i l r -> c i $ hang (pp l <+> ":=") 2 (pp r) Assign i l r -> c i $ pp l <+> ":=" `indent` pp r
List i l -> c i $ "list [" <> fsep (punctuate ";" $ map pp l) <> "]" List i l -> c i $ "list" <+> list l
Set i l -> c i $ "set [" <> fsep (punctuate ";" $ map pp l) <> "]" Set i l -> c i $ "set" <+> list l
Tuple i l -> c i $ "(" <> fsep (punctuate "," $ map pp l) <> ")" Tuple i l -> c i $ tuple l
Annot i n t -> c i $ ("(" <> pp n) <+> ":" <+> (pp t <> ")") Annot i n t -> c i $ parens (pp n <+> ":" `indent` pp t)
Attrs i ts -> c i $ "attributes [" <> fsep (punctuate ";" $ map pp ts) <> "]" Attrs i ts -> c i $ "attributes" <+> list ts
BigMap i bs -> c i $ "big_map [" <> fsep (punctuate ";" $ map pp bs) <> "]" BigMap i bs -> c i $ "big_map" <+> list bs
Map i bs -> c i $ "map [" <> fsep (punctuate ";" $ map pp bs) <> "]" Map i bs -> c i $ "map" <+> list bs
MapRemove i k m -> c i $ hang ("remove" <+> pp k) 0 ("from" <+> "map" <+> pp m) MapRemove i k m -> c i $ "remove" `indent` pp k `above` "from" <+> "map" `indent` pp m
SetRemove i k s -> c i $ hang ("remove" <+> pp k) 0 ("from" <+> "set" <+> pp s) SetRemove i k s -> c i $ "remove" `indent` pp k `above` "from" <+> "set" `indent` pp s
Indexing i a j -> c i $ pp a <> brackets (pp j) Indexing i a j -> c i $ pp a <> list [j]
Case i s az -> c i $ hang ("case" <+> pp s <+> "of") 2 (vcat $ map pp az) Case i s az -> c i $ "case" <+> pp s <+> "of" `indent` block az
Skip i -> c i $ "skip" Skip i -> c i $ "skip"
ForLoop i j s f b -> c i $ hang ("for" <+> pp j <+> ":=" <+> pp s <+> "to" <+> pp f) 2 (pp b) ForLoop i j s f b -> c i $ "for" <+> pp j <+> ":=" <+> pp s <+> "to" <+> pp f `indent` pp b
ForBox i k mv t z b -> c i $ hang ("for" <+> (pp k <> maybe empty ((" ->" <+>) . pp) mv) <+> "in" <+> pp t <+> pp z) 2 (pp b) ForBox i k mv t z b -> c i $ "for" <+> pp k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> pp z `indent` pp b
WhileLoop i f b -> c i $ hang ("while" <+> pp f) 2 (pp b) WhileLoop i f b -> c i $ "while" <+> pp f `indent` pp b
Seq i es -> c i $ hang (hang "block {" 2 (vcat $ map pp es)) 0 "}" Seq i es -> c i $ "block {" `indent` sparseBlock es `above` "}"
Lambda i ps ty b -> c i $ parens (hang ("function" <+> ("(" <> fsep (punctuate "," $ map pp ps) <> ") :") <+> pp ty) 2 (pp b)) Lambda i ps ty b -> c i $ (("function" `indent` tuple ps) `indent` (":" <+> pp ty)) `indent` pp b
MapPatch i z bs -> c i $ hang (hang "patch" 2 (pp z)) 0 (hang ("with" <+> "map") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]")) MapPatch i z bs -> c i $ "patch" `indent` pp z `above` "with" <+> "map" `indent` list bs
SetPatch i z bs -> c i $ hang (hang "patch" 2 (pp z)) 0 (hang ("with" <+> "set") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]")) SetPatch i z bs -> c i $ "patch" `indent` pp z `above` "with" <+> "set" `indent` list bs
RecordUpd i r up -> c i $ hang (pp r) 2 (hang ("with" <+> "record") 2 ("[" <> fsep (punctuate ";" $ map pp up) <> "]")) RecordUpd i r up -> c i $ pp r `indent` "with" <+> "record" `indent` list up
WrongExpr err -> pp err WrongExpr err -> pp err
instance HasComments i => Pretty (Alt i) where instance HasComments i => Pretty (Alt i) where
pp = \case pp = \case
Alt i p b -> c i $ hang ("|" <+> pp p <+> "->") 2 (pp b) Alt i p b -> c i $ "|" <+> pp p <+> "->" `indent` pp b
WrongAlt err -> pp err WrongAlt err -> pp err
instance HasComments i => Pretty (MapBinding i) where instance HasComments i => Pretty (MapBinding i) where
pp = \case pp = \case
MapBinding i k v -> c i $ hang (pp k <+> "->") 2 (pp v) MapBinding i k v -> c i $ pp k <+> "->" `indent` pp v
WrongMapBinding err -> pp err WrongMapBinding err -> pp err
instance HasComments i => Pretty (Assignment i) where instance HasComments i => Pretty (Assignment i) where
pp = \case pp = \case
Assignment i n e -> c i $ pp n <+> "=" <+> pp e Assignment i n e -> c i $ pp n <+> "=" `indent` pp e
WrongAssignment err -> pp err WrongAssignment err -> pp err
instance HasComments i => Pretty (FieldAssignment i) where instance HasComments i => Pretty (FieldAssignment i) where
pp = \case pp = \case
FieldAssignment i n e -> c i $ pp n <+> "=" <+> pp e FieldAssignment i n e -> c i $ pp n <+> "=" `indent` pp e
WrongFieldAssignment err -> pp err WrongFieldAssignment err -> pp err
instance HasComments i => Pretty (Constant i) where instance HasComments i => Pretty (Constant i) where
@ -370,7 +353,7 @@ instance HasComments i => Pretty (Constant i) where
instance HasComments i => Pretty (QualifiedName i) where instance HasComments i => Pretty (QualifiedName i) where
pp = \case pp = \case
QualifiedName i src path -> c i $ pp src <> cat (map (("." <>) . pp) path) QualifiedName i src path -> c i $ pp src <> sepByDot path
WrongQualifiedName err -> pp err WrongQualifiedName err -> pp err
instance HasComments i => Pretty (Pattern i) where instance HasComments i => Pretty (Pattern i) where
@ -378,10 +361,10 @@ instance HasComments i => Pretty (Pattern i) where
IsConstr i ctor arg -> c i $ pp ctor <> maybe empty pp arg IsConstr i ctor arg -> c i $ pp ctor <> maybe empty pp arg
IsConstant i z -> c i $ pp z IsConstant i z -> c i $ pp z
IsVar i name -> c i $ pp name IsVar i name -> c i $ pp name
IsCons i h t -> c i $ pp h <+> "#" <+> pp t IsCons i h t -> c i $ pp h <+> ("#" <+> pp t)
IsWildcard i -> c i $ "_" IsWildcard i -> c i $ "_"
IsList i l -> c i $ "[" <> fsep (punctuate ";" $ map pp l) <> "]" IsList i l -> c i $ list l
IsTuple i t -> c i $ "(" <> fsep (punctuate "," $ map pp t) <> ")" IsTuple i t -> c i $ tuple t
WrongPattern err -> pp err WrongPattern err -> pp err
@ -398,14 +381,10 @@ instance HasComments i => Pretty (Path i) where
instance HasComments i => Pretty (TField i) where instance HasComments i => Pretty (TField i) where
pp = \case pp = \case
TField i n t -> c i $ hang (pp n <> ":") 2 (pp t) TField i n t -> c i $ pp n <> ":" `indent` pp t
WrongTField err -> pp err WrongTField err -> pp err
instance HasComments i => Pretty (LHS i) where instance HasComments i => Pretty (LHS i) where
pp = \case pp = \case
LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi
WrongLHS err -> pp err WrongLHS err -> pp err
-- TODO: Use it, make more alike.
tuple :: Pretty p => [p] -> Doc
tuple xs = parens (fsep $ punctuate "," $ map pp xs)

3
tools/lsp/squirrel/src/Parser.hs
View File

@ -72,6 +72,9 @@ instance Pretty Error where
pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓" pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓"
-- | Parser of tree-sitter-made tree. -- | Parser of tree-sitter-made tree.
--
-- TODO: separate state. Polysemy?
--
newtype Parser a = Parser newtype Parser a = Parser
{ unParser { unParser
:: WriterT [Error] -- Early I though to report errors that way. :: WriterT [Error] -- Early I though to report errors that way.

32
tools/lsp/squirrel/src/Pretty.hs
View File

@ -8,7 +8,8 @@ module Pretty
) )
where where
import Data.Text import qualified Data.Text as Text
import Data.Text (Text)
import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint hiding ((<>))
@ -24,7 +25,30 @@ class Pretty p where
-- | Common instance. -- | Common instance.
instance Pretty Text where instance Pretty Text where
pp = text . unpack pp = text . Text.unpack
-- | TODO: tuple, not list; actually /use/ it. tuple :: Pretty p => [p] -> Doc
wrap [l, r] a = hang (hang l 2 r) 0 r tuple = parens . train ","
list :: Pretty p => [p] -> Doc
list = brackets . train ";"
infixr 2 `indent`
indent a b = hang a 2 b
infixr 1 `above`
above a b = hang a 0 b
train sep = fsep . punctuate sep . map pp
block :: Pretty p => [p] -> Doc
block = vcat . map pp
sepByDot :: Pretty p => [p] -> Doc
sepByDot = cat . map (("." <>) . pp)
mb :: Pretty a => (Doc -> Doc) -> Maybe a -> Doc
mb f = maybe empty (f . pp)
sparseBlock :: Pretty a => [a] -> Doc
sparseBlock = vcat . punctuate "\n" . map (($$ empty) . pp)