[LIGO-25] Add ReasonLIGO parser

Problem: With generated ReasonLIGO grammar we need to develop its
parser as well. With it we also need to restructure AST a bit
and add expressions that are used for ReasonLIGO specifically.

Solution: Add ReasonLIGO parser and some dummy examples of its
usage, adapt AST to it, rename LIGO to AST.

tools/lsp/squirrel/app/Main.hs

@@ -25,7 +25,6 @@ import           Language.Haskell.LSP.VFS
 import           System.Exit
 import qualified System.Log                            as L
 
-import           Duplo.Pretty
 import           Duplo.Error
 import           Duplo.Tree (collect)
 
@@ -35,6 +34,7 @@ import           Range
 import           Product
 import           AST                                           hiding (def)
 import qualified AST.Find                              as Find
+import           AST.Pascaligo.Parser 
 -- import           Error
 
 main :: IO ()
@@ -219,7 +219,7 @@ loadFromVFS funs uri = do
   Just vf <- Core.getVirtualFileFunc funs $ J.toNormalizedUri uri
   let txt = virtualFileText vf
   let Just fin = J.uriToFilePath uri
-  (tree, _) <- runParserM . recognise =<< toParseTree (Text fin txt)
+  (tree, _) <- runParserM . recognise =<< mkRawTreePascal (Text fin txt)
   return $ addLocalScopes tree
 
 -- loadByURI
@@ -242,7 +242,7 @@ collectErrors
 collectErrors funs uri path version = do
   case path of
     Just fin -> do
-      (tree, errs) <- runParserM . recognise =<< toParseTree (Path fin)
+      (tree, errs) <- runParserM . recognise =<< mkRawTreePascal (Path fin)
       Core.publishDiagnosticsFunc funs 100 uri version
         $ partitionBySource
         $ map errorToDiag (errs <> map (getElem *** void) (collect tree))

tools/lsp/squirrel/src/AST.hs

@@ -1,11 +1,7 @@
-
+-- | The "all things AST"-module.
-{- | The "all things AST"-module.
--}
-
 module AST (module M) where
 
-import AST.Types      as M
-import AST.Parser     as M
-import AST.Scope      as M
-import AST.Find       as M
 import AST.Completion as M
+import AST.Find as M
+import AST.Scope as M
+import AST.Skeleton as M

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

@@ -2,22 +2,19 @@
 module AST.Completion where
 
 import Data.Function (on)
+import Data.List (isSubsequenceOf, nubBy)
+import Data.Maybe (listToMaybe)
 import Data.Text (Text)
 import qualified Data.Text as Text
-import Data.Maybe (listToMaybe)
-import Data.List (isSubsequenceOf, nubBy)
 
-import Duplo.Tree
 import Duplo.Lattice
 import Duplo.Pretty
+import Duplo.Tree
 
-import AST.Types
 import AST.Scope
--- import AST.Parser
+import AST.Skeleton
-import Range
 import Product
-
+import Range
-import Debug.Trace
 
 data Completion = Completion
   { cName :: Text

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

@@ -5,20 +5,18 @@ import Control.Monad
 
 import Data.Maybe (listToMaybe)
 
-import Duplo.Tree
-import Duplo.Pretty
 import Duplo.Lattice
+import Duplo.Pretty
+import Duplo.Tree
 
 import Data.Text (Text)
 
-import AST.Types
 import AST.Scope
+import AST.Skeleton
 
 import Product
 import Range
 
--- import Debug.Trace
-
 type CanSearch xs =
   ( Contains [ScopedDecl] xs
   , Contains Range xs

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

@@ -1,14 +1,9 @@
-
+-- | Parser for a PascaLigo contract.
-{- | Parser for a contract.
+module AST.Pascaligo.Parser where
--}
-
-module AST.Parser
-  -- (example, contract, sample)
-  where
 
 import Data.Maybe (isJust)
 
-import AST.Types
+import AST.Skeleton
 
 import Duplo.Error
 import Duplo.Tree
@@ -45,24 +40,24 @@ example = "../../../src/test/contracts/coase.ligo"
 
 sample' :: FilePath -> IO (LIGO Info)
 sample' f
-  =   toParseTree (Path f)
+  =   mkRawTreePascal (Path f)
   >>= runParserM . recognise
   >>= return . fst
 
 source' :: FilePath -> IO ()
 source' f
-  =   toParseTree (Path f)
+  =   mkRawTreePascal (Path f)
   >>= print . pp
 
 sample :: IO ()
 sample
-  =   toParseTree (Path example)
+  =   mkRawTreePascal (Path example)
   >>= runParserM . recognise
   >>= print . pp . fst
 
 source :: IO ()
 source
-  =   toParseTree (Path example)
+  =   mkRawTreePascal (Path example)
   >>= print . pp
 
 recognise :: RawTree -> ParserM (LIGO Info)
@@ -100,7 +95,7 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
         "skip"              -> return Skip
         "case_expr"         -> Case      <$> field  "subject"    <*> fields   "case"
         "case_instr"        -> Case      <$> field  "subject"    <*> fields   "case"
-        "fun_expr"          -> Lambda    <$> field  "parameters" <*> field    "type"  <*> field "body"
+        "fun_expr"          -> Lambda    <$> field  "parameters" <*> fieldOpt    "type"  <*> field "body"
         "for_cycle"         -> ForLoop   <$> field  "name"       <*> field    "begin" <*> field "end" <*> fieldOpt "step" <*> field "body"
         "for_box"           -> ForBox    <$> field  "key"        <*> fieldOpt "value" <*> field "kind"  <*> field "collection" <*> field "body"
         "while_loop"        -> WhileLoop <$> field  "breaker"    <*> field    "body"
@@ -175,7 +170,7 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
       boilerplate \case
         "fun_decl"   -> Function <$> (isJust <$> fieldOpt "recursive") <*> field "name" <*> field "parameters" <*> field "type" <*> field "body"
         "const_decl" -> Const    <$>             field    "name"       <*> field "type" <*> field "value"
-        "var_decl"   -> Var      <$>             field    "name"       <*> field "type" <*> field "value"
+        "var_decl"   -> Var      <$>             field    "name"       <*> fieldOpt "type" <*> field "value"
         "type_decl"  -> TypeDecl <$>             field    "typeName"   <*> field "typeValue"
         "include"    -> Include  <$>             field    "filename"
         _            -> fallthrough

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

@@ -0,0 +1,225 @@
+-- | Parser for ReasonLigo contract
+
+module AST.Reasonligo.Parser where
+
+import           Duplo.Error
+import           Duplo.Pretty
+import           Duplo.Tree
+
+import           AST.Skeleton
+
+import           Parser
+import           ParseTree
+import           Product
+
+example :: FilePath
+-- example = "../../../src/test/contracts/counter.religo"
+-- example = "./contracts/variant.religo"
+-- example = "./contracts/amount.religo"
+example = "./contracts/multisig.religo"
+-- example = "../../../src/test/contracts/FA1.2.religo"
+-- example = "../../../src/test/contracts/multisig.religo"
+-- example = "../../../src/test/contracts/lambda.religo"
+-- example = "../../../src/test/contracts/record.religo"
+-- example = "../../../src/test/contracts/tuple_type.religo"
+-- example = "../../../src/test/contracts/empty_case.religo"
+-- example = "./contracts/empty_case.religo"
+-- example = "./contracts/tuple_type.religo"
+-- example = "./contracts/assert.religo"
+-- example = "./contracts/tuples_no_annotation.religo"
+-- example = "./contracts/match.religo"
+-- example = "./contracts/let_multiple.religo"
+-- example = "./contracts/attributes.religo"
+-- example = "./contracts/lambda.religo"
+-- example = "./contracts/arithmetic.religo"
+-- example = "./contracts/letin.religo"
+
+raw :: IO ()
+raw = mkRawTreeReason (Path example)
+    >>= print . pp
+
+sample :: IO ()
+sample = mkRawTreeReason (Path example)
+    >>= runParserM . recognise
+    >>= print . pp . fst
+
+recognise :: RawTree -> ParserM (LIGO Info)
+recognise = descent (\_ -> error . show . pp) $ map usingScope
+  [ -- Contract
+    Descent do
+      boilerplate $ \case
+        "contract" -> RawContract <$> fields "declaration"
+        _ -> fallthrough
+
+  -- ReasonExpr
+  , Descent do
+      boilerplate $ \case
+        "bracket_block" -> Block <$> fields "statement" <*> fieldOpt "return"
+        _ -> fallthrough
+
+
+    -- Expr
+  , Descent do
+      boilerplate $ \case
+        "fun_call"          -> Apply     <$> field  "f"         <*> field "arguments"
+        "lambda_call" -> Apply <$> field "lambda" <*> field "arguments" -- TODO: maybe a separate apply?
+        "arguments"         -> Tuple     <$> fields "argument"
+        "unary_call"       -> UnOp      <$> field  "negate"    <*> field "arg"
+        "binary_call"             -> BinOp     <$> field  "left"      <*> field "op"   <*> field "right"
+        "constructor_call" -> Apply <$> field "constructor" <*> field "parameters"
+        "block"             -> Seq       <$> fields "statement"
+        "list_expr"         -> List      <$> fields "element"
+        "list_access"         -> ListAccess <$> field "name" <*> fields "indexes"
+        "annot_expr"        -> Annot     <$> field  "subject"   <*> field "type"
+        "conditional"       -> If        <$> field  "selector"  <*> field "then" <*> field "else"
+        "record_expr"       -> Record    <$> fields "assignment"
+        "tuple_expr"        -> Tuple     <$> fields "element"
+
+        "switch_instr"        -> Case      <$> field  "subject"    <*> fields   "case"
+        "lambda"          -> Lambda    <$> field  "arguments" <*> fieldOpt    "lambda_type"  <*> field "lambda_body"
+        _                   -> fallthrough
+
+    -- Pattern
+  , Descent do
+      boilerplate $ \case
+        "constr_pattern" -> IsConstr <$> field  "constr" <*> fieldOpt "arguments"
+        "tuple_pattern"       -> IsTuple  <$> fields "element"
+        "cons_pattern"        -> IsCons   <$> field  "head"   <*> field "tail"
+        "annot_pattern"       -> IsAnnot <$> field "subject" <*> field "type"
+        _                     -> fallthrough
+
+    -- Alt
+  , Descent do
+      boilerplate $ \case
+        "alt"  -> Alt <$> field "pattern" <*> field  "body"
+        _                   -> fallthrough
+
+    -- Record fields
+  , Descent do
+      boilerplate $ \case
+        "record_field"      -> FieldAssignment <$> field "name" <*> field "value"
+        "spread" -> Spread <$> field "name"
+        _                  -> fallthrough
+
+    -- MapBinding
+  , Descent do
+      boilerplate $ \case
+        "binding" -> MapBinding <$> field "key" <*> field "value"
+        _         -> fallthrough
+
+  , Descent do
+      boilerplate' $ \case
+        ("+", _) -> return $ Op "+"
+        ("-", _) -> return $ Op "-"
+        ("mod", _) -> return $ Op "mod"
+        ("/", _) -> return $ Op "/"
+        ("*", _) -> return $ Op "*"
+        (">", _) -> return $ Op ">"
+        ("<", _) -> return $ Op "<"
+        (">=", _) -> return $ Op ">="
+        ("<=", _) -> return $ Op "<="
+        ("==", _) -> return $ Op "=="
+        ("!=", _) -> return $ Op "!="
+        ("||", _) -> return $ Op "||"
+        ("&&", _) -> return $ Op "&&"
+        ("negate", n) -> return $ Op n
+        _         -> fallthrough
+
+  , Descent do
+      boilerplate $ \case
+        "module_qualified"    -> QualifiedName <$> field "module"    <*> fields "method"
+        "struct_qualified"    -> QualifiedName <$> field "struct" <*> fields "method"
+        _                 -> fallthrough
+
+    -- Literal
+  , Descent do
+      boilerplate' $ \case
+        ("Int",    i) -> return $ Int i
+        ("Nat",    i) -> return $ Nat i
+        ("Bytes",  i) -> return $ Bytes i
+        ("String", i) -> return $ String i
+        ("Tez",    i) -> return $ Tez i
+        _             -> fallthrough
+
+    -- Declaration
+  , Descent do
+      boilerplate $ \case
+        -- TODO: Current `Let` in ast is untyped
+        "let_declaration"   -> Var      <$>             field    "binding"       <*> fieldOpt "let_type" <*> field "let_value"
+        "type_decl"  -> TypeDecl <$>             field    "type_name"   <*> field "type_value"
+        "attr_decl" -> Attribute <$> field "name"
+        _            -> fallthrough
+
+    -- Parameters
+  , Descent do
+      boilerplate $ \case
+        "parameters" -> Parameters <$> fields "parameter"
+        _            -> fallthrough
+
+    -- VarDecl
+  , Descent do
+      boilerplate $ \case
+        "param_decl" -> Decl <$> field "access" <*> field "name" <*> field "type"
+        _            -> fallthrough
+
+    -- Name
+  , Descent do
+      boilerplate' $ \case
+        ("Name", n) -> return $ Name n
+        ("and", _)  -> return $ Name "and"
+        ("or", _)   -> return $ Name "or"
+        _           -> fallthrough
+
+    -- Type
+  , Descent do
+      boilerplate $ \case
+        "fun_type"         -> TArrow   <$> field  "domain"     <*> field "codomain"
+        -- TODO: maybe only one argument of parameter list is considered
+        "type_application"      -> TApply   <$> field  "functor" <*> field "parameter"
+        "type_tuple"       -> TTuple   <$> fields "element"
+        "record_type"      -> TRecord  <$> fields "field"
+        "sum_type"         -> TSum     <$> fields "variant"
+        _                 -> fallthrough
+
+    -- Variant
+  , Descent do
+      boilerplate $ \case
+        "variant" -> Variant <$> field "constructor" <*> fieldOpt "arguments"
+        _         -> fallthrough
+
+    -- TField
+  , Descent do
+      boilerplate $ \case
+        "field_decl" -> TField <$> field "field_name" <*> field "field_type"
+        _            -> fallthrough
+
+    -- TypeName
+  , Descent do
+      boilerplate' $ \case
+        ("TypeName", name) -> return $ TypeName name
+        _                  -> fallthrough
+
+    -- Ctor
+  , Descent do
+      boilerplate' $ \case
+        ("Name_Capital", name) -> return $ Ctor name
+        ("Some", _)            -> return $ Ctor "Some"
+        ("None", _)            -> return $ Ctor "None"
+        ("Bool", b)            -> return $ Ctor b
+        ("Unit", _)            -> return $ Ctor "Unit"
+        ("Nil", _)             -> return $ Ctor "Nil"
+        _                      -> fallthrough
+
+  -- Err
+  , Descent do
+      \(r :> _, ParseTree _ _ msg) -> do
+        withComments do
+          return (r :> N :> Nil, Err msg)
+
+  , Descent do
+      \case
+        (r :> _, ParseTree "ERROR" _ msg) -> do
+          return ([] :> r :> Y :> Nil, Err msg)
+
+        _ -> fallthrough
+  ]

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

@@ -29,8 +29,7 @@ import           Duplo.Pretty
 import           Duplo.Tree
 import           Duplo.Error
 
--- import           AST.Parser
+import           AST.Skeleton
-import           AST.Types
 import           Parser
 import           Product
 import           Range
@@ -111,11 +110,12 @@ addLocalScopes
   => LIGO (Product xs)
   -> LIGO (Product ([ScopedDecl] : Maybe Category : xs))
 addLocalScopes tree =
-    fmap (\xs -> fullEnvAt envWithREfs (getRange xs) :> xs) tree1
+    fmap (\xs -> fullEnvAt envWithRefs (getRange xs) :> xs) tree1
   where
     tree0       = either (error . show) id $ runCatch $ unLetRec tree
     tree1       = addNameCategories tree0
-    envWithREfs = getEnvTree tree0
+    -- envWithREfs = getEnvTree tree0
+    envWithRefs = undefined
 
 unLetRec
   :: forall xs m
@@ -348,7 +348,7 @@ instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Bind
 
   after r = \case
     Irrefutable name    body -> do leave; def name  Nothing  (Just body) (getElem r)
-    Var         name ty body -> do leave; def name (Just ty) (Just body) (getElem r)
+    Var         name ty body -> do leave; def name       ty  (Just body) (getElem r) -- TODO: may be the source of bugs
     Const       name ty body -> do leave; def name (Just ty) (Just body) (getElem r)
 
     Function recur name _args ty body -> do
@@ -412,4 +412,4 @@ instance Scoped a CollectM (LIGO a) FieldName
 instance Scoped a CollectM (LIGO a) (Err Text)
 instance Scoped a CollectM (LIGO a) Language
 instance Scoped a CollectM (LIGO a) Parameters
-instance Scoped a CollectM (LIGO a) Ctor
+-- instance Scoped a CollectM (LIGO a) Ctor(Contains Range xs, Eq (Product xs), Scoped (Product xs) CollectM (Tree RawLigoList (Product xs)) ReasonExpr)

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

@@ -4,17 +4,16 @@
      The comments for fields in types are the type before it was made untyped.
 -}
 
-module AST.Types where
+module AST.Skeleton where
 
 import Data.Text (Text)
+import Data.Maybe (fromMaybe)
 import qualified Data.Text as Text
 
 import Duplo.Pretty
 import Duplo.Tree
 import Duplo.Error
 
--- import Debug.Trace
-
 -- | The AST for Pascali... wait. It is, em, universal one.
 --
 --   TODO: Rename; add stuff if CamlLIGO/ReasonLIGO needs something.
@@ -25,9 +24,16 @@ type RawLigoList =
   [ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
   , MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
   , RawContract, TypeName, FieldName, Language
-  , Err Text, Parameters, Ctor, Contract
+  , Err Text, Parameters, Ctor, Contract, ReasonExpr
   ]
 
+-- | ReasonLigo specific expressions
+data ReasonExpr it
+  -- TODO: Block may not need Maybe since last expr may be always `return`
+  = Block [it] (Maybe it) -- [Declaration] (Return)
+  deriving (Show) via PP (ReasonExpr it)
+  deriving stock (Functor, Foldable, Traversable)
+
 data Undefined it
   = Undefined Text
   deriving (Show) via PP (Undefined it)
@@ -57,10 +63,11 @@ data RawContract it
 
 data Binding it
   = Irrefutable  it it               -- ^ (Pattern) (Expr)
-  | Function     Bool it it it it    -- ^ (Name) Parameters (Type) (Expr)
+  | Function     Bool it it it it    -- ^ (Name) (Parameters) (Type) (Expr)
-  | Var          it it it            -- ^ (Name) (Type) (Expr)
+  | Var          it (Maybe it) it            -- ^ (Name) (Type) (Expr)
   | Const        it it it            -- ^ (Name) (Type) (Expr)
-  | TypeDecl     it it               -- ^ Name Type
+  | TypeDecl     it it               -- ^ (Name) (Type)
+  | Attribute    it                  -- ^ (Name)
   | Include      it
   deriving (Show) via PP (Binding it)
   deriving stock (Functor, Foldable, Traversable)
@@ -118,6 +125,7 @@ data Expr it
   | If        it it it -- (Expr) (Expr) (Expr)
   | Assign    it it -- (LHS) (Expr)
   | List      [it] -- [Expr]
+  | ListAccess it [it] -- (Name) [Indexes]
   | Set       [it] -- [Expr]
   | Tuple     [it] -- [Expr]
   | Annot     it it -- (Expr) (Type)
@@ -132,7 +140,7 @@ data Expr it
   | ForLoop   it it it (Maybe it) it              -- (Name) (Expr) (Expr) (Expr)
   | WhileLoop it it                    -- (Expr) (Expr)
   | Seq       [it]                     -- [Declaration]
-  | Lambda    it it it               -- [VarDecl] (Type) (Expr)
+  | Lambda    it (Maybe it) it               -- [VarDecl] (Maybe (Type)) (Expr)
   | ForBox    it (Maybe it) it it it -- (Name) (Maybe (Name)) Text (Expr) (Expr)
   | MapPatch  it [it] -- (QualifiedName) [MapBinding]
   | SetPatch  it [it] -- (QualifiedName) [Expr]
@@ -162,6 +170,7 @@ data Assignment it
 
 data FieldAssignment it
   = FieldAssignment it it -- (QualifiedName) (Expr)
+  | Spread it -- (Name)
   deriving (Show) via PP (FieldAssignment it)
   deriving stock (Functor, Foldable, Traversable)
 
@@ -180,6 +189,7 @@ data Pattern it
   | IsConstant   it -- (Constant)
   | IsVar        it -- (Name)
   | IsCons       it it -- (Pattern) (Pattern)
+  | IsAnnot      it it -- (Pattern) (Type) -- Semantically `Var`
   | IsWildcard
   | IsList       [it] -- [Pattern]
   | IsTuple      [it] -- [Pattern]
@@ -239,8 +249,10 @@ instance Pretty1 Binding where
   pp1 = \case
     Irrefutable  pat  expr     -> "irref" <+> pat  <+> "=" `indent` expr
     TypeDecl     n    ty       -> "type"  <+> n    <+> "=" `indent` ty
-    Var          name ty value -> "var"   <+> name <+> ":" <+> ty <+> ":=" `indent` value
+    -- TODO
+    Var          name ty value -> "var"   <+> name <+> ":" <+> fromMaybe "<unnanotated>" ty <+> ":=" `indent` value
     Const        name ty body  -> "const" <+> name <+> ":" <+> ty <+>  "=" `indent` body
+    Attribute name -> "[@" <.> name <.> "]"
     Include      fname         -> "#include" <+> fname
 
     Function isRec name params ty body ->
@@ -286,10 +298,18 @@ instance Pretty1 Variant where
     Variant ctor (Just ty) -> "|" <+> ctor <+> "of" `indent` ty
     Variant ctor  _        -> "|" <+> ctor
 
+instance Pretty1 ReasonExpr where
+  pp1 = \case
+    -- TODO: prettify
+    Block decls ret -> "block' {"
+      `indent` block decls
+      <+> (if null decls then "" else ";")
+      `above` maybe "" ("return" `indent`) ret `above` "}"
+
 instance Pretty1 Expr where
   pp1 = \case
     Let       decl body  -> "let" <+> decl `above` body
-    Apply     f xs       -> f <+> xs
+    Apply     f xs       -> "(" <.> f <.> ")" <+> xs
     Constant  constant   -> constant
     Ident     qname      -> qname
     BinOp     l o r      -> parens (l <+> pp o <+> r)
@@ -299,6 +319,7 @@ instance Pretty1 Expr where
     If        b t e      -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e]
     Assign    l r        -> l <+> ":=" `indent` r
     List      l          -> "list" <+> list l
+    ListAccess l ids     -> l <.> cat ((("[" <.>) . (<.> "]") . pp) <$> ids)
     Set       l          -> "set"  <+> list l
     Tuple     l          -> tuple l
     Annot     n t        -> parens (n <+> ":" `indent` t)
@@ -314,7 +335,7 @@ instance Pretty1 Expr where
     ForBox    k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b
     WhileLoop f b        -> "while" <+> f `indent` b
     Seq       es         -> "block {" `indent` block es `above` "}"
-    Lambda    ps ty b    -> (("function" `indent` ps) `indent` (":" <+> ty)) `indent` b
+    Lambda    ps ty b    -> (("lam" `indent` ps) `indent` (":" <+> fromMaybe "<unnanotated>" ty)) `indent` "=>" `indent` b
     MapPatch  z bs       -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs
     SetPatch  z bs       -> "patch" `indent` z `above` "with" <+> "set" `indent` list bs
     RecordUpd r up       -> r `indent` "with" <+> "record" `indent` list up
@@ -334,6 +355,7 @@ instance Pretty1 Assignment where
 instance Pretty1 FieldAssignment where
   pp1 = \case
     FieldAssignment      n e -> n <+> "=" `indent` e
+    Spread n -> "..." <+> n
 
 instance Pretty1 Constant where
   pp1 = \case
@@ -354,6 +376,7 @@ instance Pretty1 Pattern where
     IsConstant   z         -> z
     IsVar        name      -> name
     IsCons       h t       -> h <+> ("#" <+> t)
+    IsAnnot      s t       -> "(" <+> s <+> ":" <+> t <+> ")"
     IsWildcard             -> "_"
     IsList       l         -> list l
     IsTuple      t         -> tuple t

tools/lsp/squirrel/src/Debouncer.hs

@@ -31,8 +31,8 @@ debounced act = do
     putMVar i i'
     readMVar o >>= either throwM return
 
-test :: IO ([Int] -> IO Int)
+_test :: IO ([Int] -> IO Int)
-test = debounced \s -> do
+_test = debounced \s -> do
   threadDelay 2000000
   unless (odd (length s)) do
     error "even"

tools/lsp/squirrel/src/ParseTree.hs

@@ -1,5 +1,5 @@
-
+{-# OPTIONS_GHC -Wno-orphans #-}
-{-# language StrictData #-}
+{-# LANGUAGE StrictData, TupleSections #-}
 
 {- | The input tree from TreeSitter. Doesn't have any pointers to any data
      from actual tree the TS produced and therefore has no usage limitations.
@@ -16,45 +16,43 @@ module ParseTree
 
     -- * Invoke the TreeSitter and get the tree it outputs
   , toParseTree
-  -- , example
+  , mkRawTreePascal
+  , mkRawTreeReason
   )
   where
 
-import Data.ByteString (ByteString)
+import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
+import           Data.Map
+import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-import Data.Text (Text)
+import           Data.Traversable (for)
-import Data.Traversable (for)
 
-import           TreeSitter.Parser
+import           Control.Monad ((>=>))
-import           TreeSitter.Tree hiding (Tree)
+import           Foreign.C.String (peekCString)
+import           Foreign.Marshal.Alloc (alloca)
+import           Foreign.Marshal.Array (allocaArray)
+import           Foreign.Ptr (Ptr, nullPtr)
+import           Foreign.Storable (peek, peekElemOff, poke)
 import           TreeSitter.Language
 import           TreeSitter.Node
-import           Foreign.C.String (peekCString)
+import           TreeSitter.Parser
-import           Foreign.Ptr                    ( Ptr
+import           TreeSitter.Tree hiding (Tree)
-                                                , nullPtr
-                                                )
-import           Foreign.Marshal.Alloc          ( alloca )
-import           Foreign.Marshal.Array          ( allocaArray )
-import           Foreign.Storable               ( peek
-                                                , peekElemOff
-                                                , poke
-                                                )
-import           Control.Monad ((>=>))
 
-import           System.FilePath                (takeFileName)
+import           System.FilePath (takeFileName)
 
 import           System.IO.Unsafe (unsafePerformIO)
 
-import Duplo.Pretty
+import           Duplo.Pretty as PP
-import Duplo.Tree
+import           Duplo.Tree
 
-import Range
+import           Debouncer
-import Product
+import           Product
-import Debouncer
+import           Range
 
 foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language
+foreign import ccall unsafe tree_sitter_ReasonLigo :: Ptr Language
 
 data Source
   = Path       { srcPath :: FilePath }
@@ -73,10 +71,27 @@ type RawInfo = Product [Range, Text]
 instance {-# OVERLAPS #-} Modifies RawInfo where
   ascribe (r :> n :> _) d = color 3 (pp n) <+> pp r `indent` pp d
 
+data TreeKind
+  = Error
+  | Comment
+  | Field Text
+  deriving stock (Eq, Ord)
+
+-- TODO: move and refactor
+instance (Pretty k, Pretty v) => Pretty (Map k v) where
+  pp = pp . fmap snd . toList
+
+instance Pretty TreeKind where
+  pp = \case
+    Error -> "error"
+    Comment -> "comment"
+    Field t -> "field (" PP.<.> pp t PP.<.> ")"
+
 -- | The tree tree-sitter produces.
 data ParseTree self = ParseTree
   { ptName     :: Text         -- ^ Name of the node.
   , ptChildren :: [self]       -- ^ Subtrees.
+  -- , ptChildren :: Map TreeKind self -- ^ Subtrees.
   , ptSource   :: ~Text        -- ^ Range of the node.
   }
   deriving stock (Functor, Foldable, Traversable)
@@ -90,13 +105,20 @@ instance Pretty1 ParseTree where
         (pp forest)
       )
 
+mkRawTreePascal :: Source -> IO RawTree
+mkRawTreePascal = toParseTree tree_sitter_PascaLigo
+
+mkRawTreeReason :: Source -> IO RawTree
+mkRawTreeReason = toParseTree tree_sitter_ReasonLigo
+
 -- | Feed file contents into PascaLIGO grammar recogniser.
-toParseTree :: Source -> IO RawTree
+toParseTree :: Ptr Language -> Source -> IO RawTree
-toParseTree = unsafePerformIO $ debounced inner
+toParseTree language = unsafePerformIO $ debounced inner
   where
     inner fin = do
       parser <- ts_parser_new
-      True   <- ts_parser_set_language parser tree_sitter_PascaLigo
+      -- True   <- ts_parser_set_language parser tree_sitter_PascaLigo
+      True <- ts_parser_set_language parser language
 
       src <- srcToBytestring fin
 
@@ -108,11 +130,11 @@ toParseTree = unsafePerformIO $ debounced inner
         go :: ByteString -> Node -> IO RawTree
         go src node = do
           let count = fromIntegral $ nodeChildCount node
-          allocaArray count \children -> do
+          allocaArray count $ \children -> do
-            alloca \tsNodePtr -> do
+            alloca $ \tsNodePtr -> do
               poke tsNodePtr $ nodeTSNode node
               ts_node_copy_child_nodes tsNodePtr children
-              nodes <- for [0.. count - 1] \i -> do
+              nodes <- for [0.. count - 1] $ \i -> do
                 peekElemOff children i
 
               trees <- for nodes \node' -> do
@@ -148,6 +170,7 @@ toParseTree = unsafePerformIO $ debounced inner
 
               return $ make (range :> "" :> Nil, ParseTree
                 { ptName     = Text.pack ty
+                -- , ptChildren = fromList . fmap (Comment,) $ trees -- TODO
                 , ptChildren = trees
                 , ptSource   = cutOut range src
                 })

tools/lsp/squirrel/src/Parser.hs

@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Parser where
 
@@ -17,8 +18,6 @@ import ParseTree
 import Range
 import Product
 
--- import Dsebug.Trace
-
 {-
   Comment grabber has 2 buffers: 1 and 2.
 
@@ -49,7 +48,7 @@ instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where
     tell $ fmap (\t -> (r, Err t)) errs
 
   after _ _ = do
-    modify \(_, y) -> (y, [])
+    modify $ \(_, y) -> (y, [])
 
 grabComments :: ParserM [Text]
 grabComments = do
@@ -109,7 +108,7 @@ instance Pretty ShowRange where
   pp N = "Nah"
 
 type Info    = Product [[Text], Range, ShowRange]
-type PreInfo = Product [Range, ShowRange]
+-- type PreInfo = Product [Range, ShowRange]
 
 instance
   ( Contains Range xs

tools/lsp/squirrel/src/Range.hs

@@ -2,10 +2,11 @@
 {- | Continious location inside the source and utilities.
 -}
 
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Range
   ( Range(..)
   , HasRange(..)
-  , diffRange
   , cutOut
   , point
   )
@@ -33,10 +34,6 @@ data Range = Range
   deriving (Show) via PP Range
   deriving stock (Ord)
 
--- | TODO: Ugh. Purge it.
-diffRange :: Range -> Range -> Range
-diffRange (Range ws wf f) (Range ps _ _) = Range (max ws ps) wf f
-
 instance Pretty Range where
   pp (Range (ll, lc, _) (rl, rc, _) f) =
     color 2 do