Refactor AST -> types/parser, extract Range/Printer

tools/lsp/squirrel/squirrel.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 67ec249f56014b97ea36ef06bb0dad0986e0f632e7fe62dc4393a5a081cb0493
+-- hash: f4f92cb29b0c7d516e57ceee58c9d82900fc41d82cf21f7aa033094288165072
 
 name:           squirrel
 version:        0.0.0
@@ -13,8 +13,12 @@ build-type:     Simple
 library
   exposed-modules:
       AST
+      AST.Parser
+      AST.Types
       Parser
       ParseTree
+      PrettyPrint
+      Range
   other-modules:
       Paths_squirrel
   hs-source-dirs:

tools/lsp/squirrel/src/AST.hs

@@ -1,237 +1,5 @@
 
-{- annotate tree with ranges, add offsets to ranges, store verbatim in Wrong* -}
+module AST (module M) where
 
-module AST where
+import AST.Types as M
-
+import AST.Parser as M
-import Control.Monad.State
-
-import qualified Data.Text as Text
-import Data.Text (Text)
-import Data.Void
-
-import Parser
-import ParseTree
-
-import Debug.Trace
-
-type TODO = Text
-
-data Contract info
-  = Contract      info [Declaration info]
-  | WrongContract      Error
-  deriving stock (Show)
-
-instance Stubbed (Contract info) where stub = WrongContract
-
-data Declaration info
-  = ValueDecl info (Binding info)
-  | WrongDecl      Error
-  deriving stock (Show)
-
-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
-  | WrongBinding      Error
-  deriving stock (Show)
-
-instance Stubbed (Binding info) where stub = WrongBinding
-
-data VarDecl info
-  = Decl         info (Mutable info) (Name info) (Type info)
-  | WrongVarDecl      Error
-  deriving stock (Show)
-
-instance Stubbed (VarDecl info) where stub = WrongVarDecl
-
-data Mutable info
-  = Mutable      info
-  | Immutable    info
-  | WrongMutable      Error
-  deriving stock (Show)
-
-instance Stubbed (Mutable info) where stub = WrongMutable
-
-data Type info
-  = TArrow    info  (Type info) (Type info)
-  | Record    info [(Name info, Type info)]
-  | TVar      info  (Name info)
-  | Sum       info [(Name info, [Type info])]
-  | Product   info  [Type info]
-  | TApply    info  (Name info) [Type info]
-  | WrongType      Error
-  deriving stock (Show)
-
-instance Stubbed (Type info) where stub = WrongType
-
-data Expr info
-  = Let       info [Declaration info] (Expr info)
-  | Apply     info (Expr info) (Expr info)
-  | Constant  info (Constant info)
-  | Ident     info (QualifiedName info)
-  | WrongExpr      Error
-  deriving stock (Show)
-
-instance Stubbed (Expr info) where stub = WrongExpr
-
-data Constant info
-  = Int     info Int
-  | String  info Text
-  | Float   info Double
-  | Bytes   info Text
-  | WrongConstant Error
-  deriving stock (Show)
-
-instance Stubbed (Constant info) where stub = WrongConstant
-
-data Pattern info
-  = IsConstr     info (Name info) [Pattern info]
-  | IsConstant   info (Constant info)
-  | IsVar        info (Name info)
-  | WrongPattern      Error
-  deriving stock (Show)
-
-instance Stubbed (Pattern info) where stub = WrongPattern
-
-data QualifiedName info = QualifiedName
-  { source :: Name info
-  , path   :: [Name info]
-  }
-  | WrongQualifiedName Error
-  deriving stock (Show)
-
-instance Stubbed (QualifiedName info) where stub = WrongQualifiedName
-
-data Name info = Name
-  { info    :: info
-  , raw     :: Text
-  }
-  | WrongName Error
-
-instance Stubbed (Name info) where stub = WrongName
-
-instance Show (Name info) where
-  show = \case
-    Name _ raw  -> Text.unpack raw
-    WrongName r -> "(Name? " ++ show r ++ ")"
-
-name :: Parser (Name Range)
-name = do
-  (raw, info) <- range (token "Name")
-  return Name {info, raw}
-
-contract :: Parser (Contract Range)
-contract = subtree "contract" do
-  (decls, info) <- range do
-    many "declaration" declaration
-  return (Contract info decls)
-
-declaration :: Parser (Declaration Range)
-declaration =
-  stubbed "declaration" do
-    field "declaration" do
-      (b, info) <- range binding
-      return (ValueDecl info b)
-
-par x = do
-  consume "("
-  a <- x
-  consume ")"
-  return a
-
-binding :: Parser (Binding Range)
-binding = do
-  info <- getRange
-  "fun_decl" `subtree` do
-    recur <- optional do
-      field "recursive" do
-        token "recursive"
-    consume "function"
-    name <- stubbed "name" do
-      field "name" do
-        name
-    params <-
-      field "parameters" do
-        subtree "parameters" do
-          par do
-            many "param" do
-              notFollowedBy do
-                consumeOrDie ")"
-
-              stubbed "parameters" do
-                paramDecl
-    consume ":"
-    ty <-
-      stubbed "type" do
-        field "type" type_
-    consume "is"
-    expr <- stubbed "body" do
-      field "locals" anything
-    return (Function info (recur == Just "recursive") name params ty expr)
-
-paramDecl :: Parser (VarDecl Range)
-paramDecl = do
-  info <- getRange
-  "parameter" `field` do
-    subtree "param_decl" do
-      info' <- getRange
-      mutable <- do
-        traceM "paramDecl"
-        stubbed "access" do
-          "access" `subtree` do
-            traceM "paramDecl"
-            select
-              [ consume "var"   >> return (Mutable info')
-              , consume "const" >> return (Immutable info')
-              ]
-      name <-
-        stubbed "name" do
-          field "name" name
-      consume ":"
-      ty <-
-        stubbed "type" do
-          field "type" type_
-      return (Decl info mutable name ty)
-
-newtype_ = do
-  type_
-
-type_ :: Parser (Type Range)
-type_ =
-    fun_type
-  where
-    fun_type :: Parser (Type Range)
-    fun_type = do
-      stubbed "type" do
-        subtree "fun_type" do
-          info <- getRange
-          domain <- stubbed "domain" do
-            field "domain" cartesian
-          codomain <- optional do
-            consume "->"
-            fun_type
-          return case codomain of
-            Just co -> TArrow info domain co
-            Nothing -> domain
-
-    cartesian = do
-      stubbed "cartesian" do
-        subtree "cartesian" do
-          info <- getRange
-          Product info <$> some "corety" do
-            field "element" do
-              core_type
-
-    core_type = do
-      info <- getRange
-      select
-        [ TVar info <$> typename
-        ]
-
-    typename = name
-
-tuple :: Text -> Parser a -> Parser [a]
-tuple msg = par . some msg
-
-example = "../../../src/test/contracts/address.ligo"

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

@@ -0,0 +1,131 @@
+
+module AST.Parser where
+
+import Data.Text (Text)
+
+import AST.Types
+
+import Parser
+import Range
+
+import Debug.Trace
+
+name :: Parser (Name Range)
+name = do
+  (raw, info) <- range (token "Name")
+  return Name {info, raw}
+
+contract :: Parser (Contract Range)
+contract = subtree "contract" do
+  (decls, info) <- range do
+    many "declaration" declaration
+  return (Contract info decls)
+
+declaration :: Parser (Declaration Range)
+declaration =
+  stubbed "declaration" do
+    field "declaration" do
+      (b, info) <- range binding
+      return (ValueDecl info b)
+
+par x = do
+  consume "("
+  a <- x
+  consume ")"
+  return a
+
+binding :: Parser (Binding Range)
+binding = do
+  info <- getRange
+  "fun_decl" `subtree` do
+    recur <- optional do
+      field "recursive" do
+        token "recursive"
+    consume "function"
+    name <- stubbed "name" do
+      field "name" do
+        name
+    params <-
+      field "parameters" do
+        subtree "parameters" do
+          par do
+            many "param" do
+              notFollowedBy do
+                consumeOrDie ")"
+
+              stubbed "parameters" do
+                paramDecl
+    consume ":"
+    ty <-
+      stubbed "type" do
+        field "type" type_
+    consume "is"
+    expr <- stubbed "body" do
+      field "locals" anything
+    return (Function info (recur == Just "recursive") name params ty expr)
+
+paramDecl :: Parser (VarDecl Range)
+paramDecl = do
+  info <- getRange
+  "parameter" `field` do
+    subtree "param_decl" do
+      info' <- getRange
+      mutable <- do
+        traceM "paramDecl"
+        stubbed "access" do
+          "access" `subtree` do
+            traceM "paramDecl"
+            select
+              [ consume "var"   >> return (Mutable info')
+              , consume "const" >> return (Immutable info')
+              ]
+      name <-
+        stubbed "name" do
+          field "name" name
+      consume ":"
+      ty <-
+        stubbed "type" do
+          field "type" type_
+      return (Decl info mutable name ty)
+
+newtype_ = do
+  type_
+
+type_ :: Parser (Type Range)
+type_ =
+    fun_type
+  where
+    fun_type :: Parser (Type Range)
+    fun_type = do
+      stubbed "type" do
+        subtree "fun_type" do
+          info <- getRange
+          domain <- stubbed "domain" do
+            field "domain" cartesian
+          codomain <- optional do
+            consume "->"
+            fun_type
+          return case codomain of
+            Just co -> TArrow info domain co
+            Nothing -> domain
+
+    cartesian = do
+      stubbed "cartesian" do
+        subtree "cartesian" do
+          info <- getRange
+          Product info <$> some "corety" do
+            field "element" do
+              core_type
+
+    core_type = do
+      info <- getRange
+      select
+        [ TVar info <$> typename
+        ]
+
+    typename = name
+
+tuple :: Text -> Parser a -> Parser [a]
+tuple msg = par . some msg
+
+example = "../../../src/test/contracts/address.ligo"

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

@@ -0,0 +1,117 @@
+
+{- annotate tree with ranges, add offsets to ranges, store verbatim in Wrong* -}
+
+module AST.Types where
+
+import Control.Monad.State
+
+import qualified Data.Text as Text
+import Data.Text (Text)
+import Data.Void
+
+import Parser
+import ParseTree
+
+import Debug.Trace
+
+type TODO = Text
+
+data Contract info
+  = Contract      info [Declaration info]
+  | WrongContract      Error
+  deriving stock (Show)
+
+instance Stubbed (Contract info) where stub = WrongContract
+
+data Declaration info
+  = ValueDecl info (Binding info)
+  | WrongDecl      Error
+  deriving stock (Show)
+
+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
+  | WrongBinding      Error
+  deriving stock (Show)
+
+instance Stubbed (Binding info) where stub = WrongBinding
+
+data VarDecl info
+  = Decl         info (Mutable info) (Name info) (Type info)
+  | WrongVarDecl      Error
+  deriving stock (Show)
+
+instance Stubbed (VarDecl info) where stub = WrongVarDecl
+
+data Mutable info
+  = Mutable      info
+  | Immutable    info
+  | WrongMutable      Error
+  deriving stock (Show)
+
+instance Stubbed (Mutable info) where stub = WrongMutable
+
+data Type info
+  = TArrow    info  (Type info) (Type info)
+  | Record    info [(Name info, Type info)]
+  | TVar      info  (Name info)
+  | Sum       info [(Name info, [Type info])]
+  | Product   info  [Type info]
+  | TApply    info  (Name info) [Type info]
+  | WrongType      Error
+  deriving stock (Show)
+
+instance Stubbed (Type info) where stub = WrongType
+
+data Expr info
+  = Let       info [Declaration info] (Expr info)
+  | Apply     info (Expr info) (Expr info)
+  | Constant  info (Constant info)
+  | Ident     info (QualifiedName info)
+  | WrongExpr      Error
+  deriving stock (Show)
+
+instance Stubbed (Expr info) where stub = WrongExpr
+
+data Constant info
+  = Int     info Int
+  | String  info Text
+  | Float   info Double
+  | Bytes   info Text
+  | WrongConstant Error
+  deriving stock (Show)
+
+instance Stubbed (Constant info) where stub = WrongConstant
+
+data Pattern info
+  = IsConstr     info (Name info) [Pattern info]
+  | IsConstant   info (Constant info)
+  | IsVar        info (Name info)
+  | WrongPattern      Error
+  deriving stock (Show)
+
+instance Stubbed (Pattern info) where stub = WrongPattern
+
+data QualifiedName info = QualifiedName
+  { source :: Name info
+  , path   :: [Name info]
+  }
+  | WrongQualifiedName Error
+  deriving stock (Show)
+
+instance Stubbed (QualifiedName info) where stub = WrongQualifiedName
+
+data Name info = Name
+  { info    :: info
+  , raw     :: Text
+  }
+  | WrongName Error
+
+instance Stubbed (Name info) where stub = WrongName
+
+instance Show (Name info) where
+  show = \case
+    Name _ raw  -> Text.unpack raw
+    WrongName r -> "(Name? " ++ show r ++ ")"

tools/lsp/squirrel/src/ParseTree.hs

@@ -29,6 +29,9 @@ import Text.PrettyPrint hiding ((<>))
 
 import Paths_squirrel
 
+import Range
+import PrettyPrint
+
 -- import Debug.Trace
 
 foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language
@@ -52,38 +55,33 @@ data ParseForest = Forest
   }
 
 instance Show ParseTree where
-  show = show . ppTree
+  show = show . pp
 
 instance Show ParseForest where
-  show = show . vcat . map ppPair . pfGrove
+  show = show . pp
 
-data Range = Range
+instance Pretty ParseTree where
-  { rStart  :: (Int, Int)
+  pp (ParseTree _ n _ _ (Range (sr, sc) (fr, fc)) forest) =
-  , rFinish :: (Int, Int)
+    parens
-  }
+      ( hang
-  deriving stock (Show)
+        (   quotes (text (Text.unpack n))
-
+        <+> brackets
-diffRange :: Range -> Range -> Range
+          ( int sr <> ":" <> int sc
-diffRange (Range ws wf) (Range ps _) = Range (max ws ps) wf
+          <> " - "
-
+          <> int fr <> ":" <> int fc
-ppTree :: ParseTree -> Doc
+          )
-ppTree (ParseTree _ n _ _ (Range (sr, sc) (fr, fc)) (Forest _ cs _)) =
-  parens
-    ( hang
-      (   quotes (text (Text.unpack n))
-      <+> brackets
-        ( int sr <> ":" <> int sc
-        <> " - "
-        <> int fr <> ":" <> int fc
         )
+        2
+        (pp forest)
       )
-      2
-      (vcat (map ppPair cs)))
 
-ppPair (field, tree) =
+instance Pretty ParseForest where
-  if field == Text.empty
+  pp = vcat . map ppPair . pfGrove
-  then nest 2 $ ppTree tree
+    where
-  else hang (text (Text.unpack field) <> ": ") 2 (ppTree tree)
+      ppPair (field, tree) =
+        if field == Text.empty
+        then nest 2 $ pp tree
+        else hang (text (Text.unpack field) <> ": ") 2 (pp tree)
 
 toParseTree :: FilePath -> IO ParseForest
 toParseTree fin = do

tools/lsp/squirrel/src/Parser.hs

@@ -14,6 +14,7 @@ import qualified Data.ByteString as ByteString
 import Data.ByteString (ByteString)
 
 import ParseTree
+import Range
 
 import Debug.Trace
 

tools/lsp/squirrel/src/PrettyPrint.hs

@@ -0,0 +1,11 @@
+
+module PrettyPrint
+  ( module PrettyPrint
+  , module Text.PrettyPrint
+  )
+  where
+
+import Text.PrettyPrint hiding ((<>))
+
+class Pretty p where
+  pp :: p -> Doc

tools/lsp/squirrel/src/Range.hs

@@ -0,0 +1,12 @@
+
+module Range where
+
+data Range = Range
+  { rStart  :: (Int, Int)
+  , rFinish :: (Int, Int)
+  }
+  deriving stock (Show)
+
+diffRange :: Range -> Range -> Range
+diffRange (Range ws wf) (Range ps _) = Range (max ws ps) wf
+