[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.
2020-08-11 13:33:26 +03:00 · 2020-08-11 13:33:26 +03:00 · a1a846b554
commit a1a846b554
parent 820d73f345
12 changed files with 352 additions and 99 deletions
--- a/tools/lsp/squirrel/app/Main.hs
+++ b/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))
--- a/tools/lsp/squirrel/src/AST.hs
+++ b/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
--- a/tools/lsp/squirrel/src/AST/Completion.hs
+++ b/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 Range
+import AST.Skeleton
 import Product
-
-import Debug.Trace
+import Range

 data Completion = Completion
  { cName :: Text
@ -65,4 +62,4 @@ fits  Nothing _  = True
 fits (Just c) c' = c == c'

 catFromType :: ScopedDecl -> Category
-catFromType = maybe Variable (either (const Variable) (const Type)) . _sdType
+catFromType = maybe Variable (either (const Variable) (const Type)) . _sdType
--- a/tools/lsp/squirrel/src/AST/Find.hs
+++ b/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
--- a/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs
+++ b/tools/lsp/squirrel/src/AST/Pascaligo/Parser.hs
@ -1,14 +1,9 @@
-
-{- | Parser for a contract.
-}
-
-module AST.Parser
-  -- (example, contract, sample)
-  where
+-- | Parser for a PascaLigo contract.
+module AST.Pascaligo.Parser 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
@ -276,4 +271,4 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
          return ([] :> r :> Y :> Nil, Err text')

        _ -> fallthrough
-  ]
+  ]
--- a/tools/lsp/squirrel/src/AST/Reasonligo/Parser.hs
+++ b/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
+  ]
--- a/tools/lsp/squirrel/src/AST/Scope.hs
+++ b/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.Types
+import           AST.Skeleton
 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)
--- a/tools/lsp/squirrel/src/AST/Skeleton.hs
+++ b/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)
-  | Var          it it it            -- ^ (Name) (Type) (Expr)
+  | Function     Bool it it it it    -- ^ (Name) (Parameters) (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
--- a/tools/lsp/squirrel/src/Debouncer.hs
+++ b/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 = debounced \s -> do
+_test :: IO ([Int] -> IO Int)
+_test = debounced \s -> do
  threadDelay 2000000
  unless (odd (length s)) do
    error "even"
--- a/tools/lsp/squirrel/src/ParseTree.hs
+++ b/tools/lsp/squirrel/src/ParseTree.hs
@ -1,5 +1,5 @@
-
-{-# language StrictData #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# 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           TreeSitter.Tree hiding (Tree)
+import           Control.Monad ((>=>))
+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           Foreign.Ptr                    ( Ptr
-                                                , nullPtr
-                                                )
-import           Foreign.Marshal.Alloc          ( alloca )
-import           Foreign.Marshal.Array          ( allocaArray )
-import           Foreign.Storable               ( peek
-                                                , peekElemOff
-                                                , poke
-                                                )
-import           Control.Monad ((>=>))
+import           TreeSitter.Parser
+import           TreeSitter.Tree hiding (Tree)

-import           System.FilePath                (takeFileName)
+import           System.FilePath (takeFileName)

 import           System.IO.Unsafe (unsafePerformIO)

-import Duplo.Pretty
-import Duplo.Tree
+import           Duplo.Pretty as PP
+import           Duplo.Tree

-import Range
-import Product
-import Debouncer
+import           Debouncer
+import           Product
+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 = unsafePerformIO $ debounced inner
+toParseTree :: Ptr Language -> Source -> IO RawTree
+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
-            alloca \tsNodePtr -> do
+          allocaArray count $ \children -> 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
                })
--- a/tools/lsp/squirrel/src/Parser.hs
+++ b/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
--- a/tools/lsp/squirrel/src/Range.hs
+++ b/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