From 1ed617c7d03e648d54cf7aba65579697d2d80899 Mon Sep 17 00:00:00 2001
From: Kirill Andreev <hindmost.one@gmail.com>
Date: Wed, 6 May 2020 21:59:34 +0400
Subject: [PATCH] Convert parsers to applicative interface

Problem:  The aquisition of current range is manual, and therefore
          error-prone. The names in do-syntax create visual clutter.

Solution: Hide range aquisition (which makes it possible to do automatic
          comment aquisition as well).
---
 tools/lsp/squirrel/src/AST/Parser.hs | 286 +++++++++++----------------
 tools/lsp/squirrel/src/Parser.hs     |   8 +-
 2 files changed, 122 insertions(+), 172 deletions(-)

diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs
index 1fcf35e91..eb68ecf73 100644
--- a/tools/lsp/squirrel/src/AST/Parser.hs
+++ b/tools/lsp/squirrel/src/AST/Parser.hs
@@ -11,93 +11,78 @@ import Range
 import Debug.Trace
 
 name :: Parser (Name Range)
-name = do
-  (raw, info) <- range (token "Name")
-  return Name {info, raw}
+name = ctor Name <*> token "Name"
 
 capitalName :: Parser (Name Range)
-capitalName = do
-  (raw, info) <- range (token "Name_Capital")
-  return Name {info, raw}
+capitalName = ctor Name <*> token "Name_Capital"
 
 contract :: Parser (Contract Range)
-contract = subtree "contract" do
-  (decls, info) <- range do
-    many "declaration" do
-      inside "declaration:" do
-        declaration
-
-  return (Contract info decls)
+contract =
+  ctor Contract
+  <*> subtree "contract" do
+        many "declaration" do
+          inside "declaration:" do
+            declaration
 
 declaration :: Parser (Declaration Range)
-declaration = do
-    (b, info) <- range binding
-    return (ValueDecl info b)
-  <|> do
-    (b, info) <- range vardecl
-    return (ValueDecl info b)
-  <|> do
-    (b, info) <- range constdecl
-    return (ValueDecl info b)
-  <|>
-    typedecl
+declaration
+  =   do ctor ValueDecl <*> binding
+  <|> do ctor ValueDecl <*> vardecl
+  <|> do ctor ValueDecl <*> constdecl
+  <|> typedecl
 
 typedecl :: Parser (Declaration Range)
 typedecl = do
   subtree "type_decl" do
-    r <- getRange
-    n <- inside "typeName:"  name
-    t <- inside "typeValue:" newtype_
-    return $ TypeDecl r n t
+    ctor TypeDecl
+      <*> inside "typeName:"  name
+      <*> inside "typeValue:" newtype_
 
 vardecl :: Parser (Binding Range)
 vardecl = do
   subtree "var_decl" do
-    r  <- getRange
-    n  <- inside "name:"  name
-    ty <- inside "type:"  type_
-    b  <- inside "value:" expr
-    return (Var r n ty b)
+    ctor Var
+      <*> inside "name:"  name
+      <*> inside "type:"  type_
+      <*> inside "value:" expr
 
 constdecl :: Parser (Binding Range)
 constdecl = do
   subtree "const_decl" do
-    r  <- getRange
-    n  <- inside "name" name
-    ty <- inside "type" type_
-    b  <- inside "value" expr
-    return (Const r n ty b)
-
-par x = do
-  consume "("
-  a <- x
-  consume ")"
-  return a
+    ctor Const
+      <*> inside "name" name
+      <*> inside "type" type_
+      <*> inside "value" expr
 
 binding :: Parser (Binding Range)
 binding = do
-  info <- getRange
   inside ":fun_decl" do
-    recur <- optional $ inside "recursive" $ token "recursive"
-    name  <- inside "name:"  name
-    params <-
-      inside "parameters:parameters" do
-        many "param" do
-          notFollowedBy do
-            consumeOrDie ")"
+    ctor Function
+      <*> recursive
+      <*> inside "name:"  name
+      <*> inside "parameters:parameters" do
+            many "param" do
+              notFollowedBy do
+                consumeOrDie ")"
 
-          stubbed "parameters" paramDecl
-    ty  <- inside "type:" type_
-    exp <- inside "body:" letExpr
-    return (Function info (recur == Just "recursive") name params ty exp)
+              stubbed "parameters" paramDecl
+      <*> inside "type:" type_
+      <*> inside "body:" letExpr
+
+recursive = do
+  mr <- optional do
+    inside "recursive" do
+      token "recursie"
+
+  return $ maybe False (== "recursive") mr
 
 expr :: Parser (Expr Range)
 expr = stubbed "expr" do
   select
     [ Ident <$> getRange <*> do
-        r <- getRange
-        n <- name
-        return $ QualifiedName r n []
+        ctor QualifiedName
+          <*> name
+          <*> pure []
     , opCall
     , fun_call
     , record_expr
@@ -116,64 +101,51 @@ expr = stubbed "expr" do
 method_call :: Parser (Expr Range)
 method_call = do
   subtree "projection_call" do
-    r <- getRange
-    (f, r') <- field "f" $ range projection
-    xs <- inside "arguments" arguments
-    return $ Apply r (Ident r' f) xs
+    ctor Apply
+      <*> do ctor Ident <*> field "f" projection
+      <*> inside "arguments" arguments
 
 projection :: Parser (QualifiedName Range)
 projection = do
   subtree "data_projection" do
-    r  <- getRange
-    s  <- inside "struct" name
-    is <- many "selection" selection
-    return $ QualifiedName r s is
+    ctor QualifiedName
+      <*> inside "struct" name
+      <*> many "selection" selection
 
 selection :: Parser (Path Range)
 selection = do
-  inside "index:selection" $ do
-      r <- getRange
-      n <- name
-      return $ At r n
-    <|> do
-      r <- getRange
-      n <- token "Int"
-      return $ Ix r n
+  inside "index:selection"
+    $   do ctor At <*> name
+    <|> do ctor Ix <*> token "Int"
 
 par_call :: Parser (Expr Range)
 par_call = do
   subtree "par_call" do
-    r  <- getRange
-    f  <- inside "f" expr
-    az <- inside "arguments" arguments
-    return $ Apply r f az
+    ctor Apply
+      <*> inside "f" expr
+      <*> inside "arguments" arguments
 
 int_literal :: Parser (Expr Range)
 int_literal = do
-  r <- getRange
-  i <- token "Int"
-  return $ Constant r (Int r i)
+  ctor Constant
+    <*> do ctor Int <*> token "Int"
 
 record_expr :: Parser (Expr Range)
 record_expr = do
   subtree "record_expr" do
-    r  <- getRange
-    az <- many "assignment" do
-      inside "assignment:field_assignment" do
-        r <- getRange
-        n <- inside "name" name
-        e <- inside "_rhs" expr
-        return $ Assignment r n e
-    return $ Record r az
+    ctor Record <*> do
+      many "assignment" do
+        inside "assignment:field_assignment" do
+          ctor Assignment
+            <*> inside "name" name
+            <*> inside "_rhs" expr
 
 fun_call :: Parser (Expr Range)
 fun_call = do
   subtree "fun_call" do
-    r <- getRange
-    (f, r') <- range $ inside "f" function_id
-    xs <- inside "arguments" do
-      arguments
-    return $ Apply r (Ident r' f) xs
+    ctor Apply
+      <*> do ctor Ident <*> inside "f" function_id
+      <*> inside "arguments" arguments
 
 arguments =
   subtree "arguments" do
@@ -182,64 +154,55 @@ arguments =
 
 function_id :: Parser (QualifiedName Range)
 function_id = select
-  [ do
-      r <- getRange
-      n <- name
-      return $ QualifiedName r n []
+  [ ctor QualifiedName
+      <*> name
+      <*> pure []
   , do
       subtree "module_field" do
-        r     <- getRange
-        whole <- inside "module" capitalName
-        path  <- inside "method" name
-        return $ QualifiedName r whole [At r path]
+        ctor QualifiedName
+          <*> inside "module" capitalName
+          <*> do pure <$> do ctor At <*> inside "method" name
   ]
 
 opCall :: Parser (Expr Range)
 opCall = do
-  subtree "op_expr" $ do
-      inside "the" do
-        expr
-    <|> do
-      i <- getRange
-      l <- inside "arg1" expr
-      o <- inside "op"   anything
-      r <- inside "arg2" expr
-      return $ BinOp i l o r
+  subtree "op_expr"
+    $   do inside "the" expr
+    <|> do ctor BinOp
+             <*> inside "arg1" expr
+             <*> inside "op"   anything
+             <*> inside "arg2" expr
 
 letExpr = do
   subtree "let_expr" do
-    r <- getRange
-    decls <- optional do
-      inside "locals:block" do
-        many "decl" do
-          inside "statement" do
-            declaration <|> statement
-    body <- inside "body"expr
+    ctor let'
+      <*> optional do
+        inside "locals:block" do
+          many "decl" do
+            inside "statement" do
+              declaration <|> statement
+      <*> inside "body"expr
 
-    return case decls of
+  where
+    let' r decls body = case decls of
       Just them -> Let r them body
       Nothing   -> body
 
 statement :: Parser (Declaration Range)
-statement = do
-  r <- getRange
-  e <- expr
-  return $ Action r e
+statement = ctor Action <*> expr
 
 paramDecl :: Parser (VarDecl Range)
 paramDecl = do
   info <- getRange
   inside "parameter:param_decl" do
-    info' <- getRange
-    mutable <- do
-      inside ":access" do
-        select
-          [ consume "var"   >> return (Mutable   info')
-          , consume "const" >> return (Immutable info')
-          ]
-    name <- inside "name" name
-    ty <- inside "type" type_
-    return (Decl info mutable name ty)
+    ctor Decl
+      <*> do inside ":access" do
+              select
+                [ ctor Mutable   <* consumeOrDie "var"
+                , ctor Immutable <* consumeOrDie "const"
+                ]
+     <*> inside "name" name
+     <*> inside "type" type_
 
 newtype_ = select
   [ record_type
@@ -249,19 +212,16 @@ newtype_ = select
 
 record_type = do
   subtree "record_type" do
-    r  <- getRange
-    fs <- many "field" do
-      inside "field" do
-        field_decl
-    traceShowM fs
-    return $ TRecord r fs
+    ctor TRecord
+      <*> many "field" do
+        inside "field" do
+          field_decl
 
 field_decl = do
   subtree "field_decl" do
-    r <- getRange
-    n <- inside "fieldName" name
-    t <- inside "fieldType" type_
-    return $ TField r n t
+    ctor TField
+      <*> inside "fieldName" name
+      <*> inside "fieldType" type_
 
 type_ :: Parser (Type Range)
 type_ =
@@ -270,48 +230,40 @@ type_ =
     fun_type :: Parser (Type Range)
     fun_type = do
       inside ":fun_type" do
-        info <- getRange
-        domain <- inside "domain" cartesian
-        codomain <- optional do
-          consume "->"
-          fun_type
+        ctor tarrow
+          <*>             inside "domain"  cartesian
+          <*> optional do inside "codomain" fun_type
 
-        return case codomain of
-          Just co -> TArrow info domain co
-          Nothing -> domain
+      where
+        tarrow info domain codomain =
+          case codomain of
+            Just co -> TArrow info domain co
+            Nothing -> domain
 
     cartesian = do
       inside ":cartesian" do
-        info <- getRange
-        TProduct info <$> some "corety" do
+        ctor TProduct <*> some "corety" do
           inside "element" do
             core_type
 
     core_type = do
-      info <- getRange
       select
-        [ TVar info <$> typename
+        [ ctor TVar <*> name
         , subtree "invokeBinary" do
-            r  <- getRange
-            f  <- inside "typeConstr" name
-            xs <- inside "arguments"  typeTuple
-            return $ TApply r f xs
+            ctor TApply
+              <*> inside "typeConstr" name
+              <*> inside "arguments"  typeTuple
         ]
 
-    typename = name
-
 typeTuple :: Parser [Type Range]
 typeTuple = do
   subtree "type_tuple" do
     many "type tuple element" do
       inside "element" type_
 
-tuple :: Text -> Parser a -> Parser [a]
-tuple msg = par . some msg
-
--- example = "../../../src/test/contracts/application.ligo"
+example = "../../../src/test/contracts/application.ligo"
 -- example = "../../../src/test/contracts/address.ligo"
-example = "../../../src/test/contracts/amount.ligo"
+-- example = "../../../src/test/contracts/amount.ligo"
 -- example = "../../../src/test/contracts/application.ligo"
 -- example = "../../../src/test/contracts/application.ligo"
 -- example = "../../../src/test/contracts/application.ligo"
diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs
index 7039778e5..8f3c35fc2 100644
--- a/tools/lsp/squirrel/src/Parser.hs
+++ b/tools/lsp/squirrel/src/Parser.hs
@@ -295,20 +295,18 @@ inside sig parser = do
   let st       = Text.drop 1 st'
   if Text.null f
   then do
-    traceShowM ("subtree", st)
     subtree st do
-      traceShowM ("stubbed", st)
       stubbed f do
         parser
   else do
-    traceShowM ("field", f)
     field f do
-      traceShowM ("stubbed", f)
       stubbed f do
         if Text.null st
         then do
           parser
         else do
-          traceShowM ("subtree", st)
           subtree st do
             parser
+
+ctor :: (Range -> a) -> Parser a
+ctor = (<$> getRange)