Convert to monotyped AST

tools/lsp/squirrel/app/Main.hs

@@ -27,6 +27,7 @@ import           ParseTree
 import           Parser
 import           Range
 import           AST
+import           HasErrors
 import           Pretty
 
 main :: IO ()

tools/lsp/squirrel/package.yaml

@@ -4,29 +4,38 @@ dependencies:
   - base
   - bytestring
   - data-default
+  - data-fix
   - lens
   - mtl
+  - pretty
   - template-haskell
   - text
   - tree-sitter
-  - pretty
 
 default-extensions:
-  - LambdaCase
+  - BangPatterns
   - BlockArguments
-  - OverloadedStrings
+  - DataKinds
-  - GeneralisedNewtypeDeriving
+  - DeriveFoldable
+  - DeriveFunctor
+  - DeriveTraversable
   - DerivingStrategies
   - DerivingVia
+  - FlexibleContexts
   - FlexibleInstances
+  - GADTs
+  - GeneralisedNewtypeDeriving
+  - LambdaCase
+  - MultiParamTypeClasses
   - NamedFieldPuns
-  - BangPatterns
+  - OverloadedStrings
-  - ScopedTypeVariables
   - QuasiQuotes
+  - ScopedTypeVariables
+  - StandaloneDeriving
   - TemplateHaskell
-  - DeriveFunctor
+  - TypeFamilies
-  - DeriveFoldable
+  - TypeOperators
-  - DeriveTraversable
+  - UndecidableInstances
 
 ghc-options: -freverse-errors -Wall -threaded
 

tools/lsp/squirrel/squirrel.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e30e95968ee812129049606c1bdd5ab3a97ce79d1da5f70f38adaf4bc91f4a4a
+-- hash: fc91e2bbafd609769dba91a90992c659e68f017fa28f156cd261cd553083a47d
 
 name:           squirrel
 version:        0.0.0
@@ -17,16 +17,20 @@ library
       AST.Parser
       AST.Scope
       AST.Types
+      Lattice
       Parser
       ParseTree
       Pretty
       Range
       TH
+      Tree
+      Union
+      Update
   other-modules:
       Paths_squirrel
   hs-source-dirs:
       src/
-  default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell DeriveFunctor DeriveFoldable DeriveTraversable
+  default-extensions: BangPatterns BlockArguments DataKinds DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances GADTs GeneralisedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies TypeOperators UndecidableInstances
   ghc-options: -freverse-errors -Wall -threaded
   include-dirs:
       vendor
@@ -36,6 +40,7 @@ library
       base
     , bytestring
     , data-default
+    , data-fix
     , lens
     , mtl
     , pretty
@@ -50,12 +55,13 @@ executable squirrel
       Paths_squirrel
   hs-source-dirs:
       app/
-  default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell DeriveFunctor DeriveFoldable DeriveTraversable
+  default-extensions: BangPatterns BlockArguments DataKinds DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances GADTs GeneralisedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies TypeOperators UndecidableInstances
   ghc-options: -freverse-errors -Wall -threaded
   build-depends:
       base
     , bytestring
     , data-default
+    , data-fix
     , haskell-lsp
     , hslogger
     , interpolate

tools/lsp/squirrel/src/AST.hs

@@ -3,5 +3,4 @@ module AST (module M) where
 
 import AST.Types as M
 import AST.Parser as M
-import AST.Errors as M
 import AST.Scope as M

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

@@ -1,292 +0,0 @@
-
-{-
-  The AST and auxillary types along with their pretty-printers.
-
-  TODO: Untangle pretty-printing mess into combinators.
-  TODO: Store offending text verbatim in Wrong*.
--}
-
-module AST.Errors where
-
-import Parser
-import AST.Types
-
-class HasErrors h where
-  errors :: h -> [Error]
-
-instance {-# OVERLAPPABLE #-} (HasErrors a, Foldable f) => HasErrors (f a) where
-  errors = foldMap errors
-
-instance HasErrors (Contract i) where
-  errors = \case
-    Contract _ ds  -> errors ds
-    WrongContract err -> return err
-
--- data Contract info
---   = Contract      info [Declaration info]
---   | WrongContract      Error
-
-instance HasErrors (Declaration i) where
-  errors = \case
-    ValueDecl _ bind -> errors bind
-    TypeDecl _ n ty -> errors n <> errors ty
-    Action _ e -> errors e
-    Include _ _ -> fail "text"
-    WrongDecl err -> return err
-
--- data Declaration info
---   = ValueDecl info (Binding info)
---   | TypeDecl  info (Name info) (Type info)
---   | Action    info (Expr info)
---   | Include   info Text
---   | WrongDecl      Error
-
-instance HasErrors (Binding i) where
-  errors = \case
-    Irrefutable _ a b -> errors a <> errors b
-    Function _ _ a b c d -> errors a <> errors b <> errors c <> errors d
-    Var _ a b c -> errors a <> errors b <> errors c
-    Const _ a b c -> errors a <> errors b <> errors c
-    WrongBinding e -> return e
-
--- data Binding info
---   = Irrefutable  info (Pattern info) (Expr info)
---   | Function     info Bool (Name info) [VarDecl info] (Type info) (Expr info)
---   | Var          info (Name info) (Type info) (Expr info)
---   | Const        info (Name info) (Type info) (Expr info)
---   | WrongBinding      Error
-
-instance HasErrors (VarDecl i) where
-  errors = \case
-    Decl _ a b c -> errors a <> errors b <> errors c
-    WrongVarDecl e -> return e
-
--- data VarDecl info
---   = Decl         info (Mutable info) (Name info) (Type info)
---   | WrongVarDecl      Error
-
-instance HasErrors (Mutable i) where
-  errors = \case
-    WrongMutable e -> return e
-    _              -> fail "none"
-
--- data Mutable info
---   = Mutable      info
---   | Immutable    info
---   | WrongMutable      Error
-
-instance HasErrors (Type i) where
-  errors = \case
-    TArrow _ a b -> errors a <> errors b
-    TRecord _ fs -> errors fs
-    TVar _ a -> errors a
-    TSum _ cs -> errors cs
-    TProduct _ es -> errors es
-    TApply _ f xs -> errors f <> errors xs
-
--- data Type info
---   = TArrow    info  (Type info) (Type info)
---   | TRecord   info [TField info]
---   | TVar      info  (Name info)
---   | TSum      info [Variant info]
---   | TProduct  info  [Type info]
---   | TApply    info  (Name info) [Type info]
---   | WrongType      Error
-
-instance HasErrors (Variant i) where
-  errors = \case
-    Variant _ a b -> errors a <> errors b
-    WrongVariant e -> return e
-
--- data Variant info
---   = Variant info (Name info) (Maybe (Type info))
---   | WrongVariant Error
-
-instance HasErrors (TField i) where
-  errors = \case
-    TField _ a b -> errors a <> errors b
-    WrongTField e -> return e
-
--- data TField info
---   = TField info (Name info) (Type info)
---   | WrongTField Error
-
-instance HasErrors (Expr i) where
-  errors = \case
-    Let _ ds b -> errors ds <> errors b
-    Apply _ f xs -> errors f <> errors xs
-    Constant _ c -> errors c
-    Ident _ q -> errors q
-    BinOp _ l _ r -> errors l <> errors r
-    UnOp _ _ o -> errors o
-    Record _ fs -> errors fs
-    If _ a b c -> errors a <> errors b <> errors c
-    Assign _ a b -> errors a <> errors b
-    List _ l -> errors l
-    Set _ l -> errors l
-    Tuple _ l -> errors l
-    Annot _ a b -> errors a <> errors b
-    Attrs _ _ -> fail "none"
-    BigMap _ l -> errors l
-    Map _ l -> errors l
-    MapRemove _ a b -> errors a <> errors b
-    SetRemove _ a b -> errors a <> errors b
-    Indexing _ a b -> errors a <> errors b
-    Case _ a bs -> errors a <> errors bs
-    Skip _ -> fail "none"
-    ForLoop _ a b c d -> errors a <> errors b <> errors c <> errors d
-    WhileLoop _ a b -> errors a <> errors b
-    Seq _ ds -> errors ds
-    Lambda _ ps b c -> errors ps <> errors b <> errors c
-    ForBox _ a b _ c d -> errors a <> errors b <> errors c <> errors d
-    MapPatch _ a bs -> errors a <> errors bs
-    SetPatch _ a bs -> errors a <> errors bs
-    RecordUpd _ a bs -> errors a <> errors bs
-    WrongExpr e -> return e
-
--- data Expr info
---   = Let       info [Declaration info] (Expr info)
---   | Apply     info (Expr info) [Expr info]
---   | Constant  info (Constant info)
---   | Ident     info (QualifiedName info)
---   | BinOp     info (Expr info) Text (Expr info)
---   | UnOp      info Text (Expr info)
---   | Record    info [Assignment info]
---   | If        info (Expr info) (Expr info) (Expr info)
---   | Assign    info (LHS info) (Expr info)
---   | List      info [Expr info]
---   | Set       info [Expr info]
---   | Tuple     info [Expr info]
---   | Annot     info (Expr info) (Type info)
---   | Attrs     info [Text]
---   | BigMap    info [MapBinding info]
---   | Map       info [MapBinding info]
---   | MapRemove info (Expr info) (QualifiedName info)
---   | SetRemove info (Expr info) (QualifiedName info)
---   | Indexing  info (QualifiedName info) (Expr info)
---   | Case      info (Expr info) [Alt info]
---   | Skip      info
---   | ForLoop   info (Name info) (Expr info) (Expr info) (Expr info)
---   | WhileLoop info (Expr info) (Expr info)
---   | Seq       info [Declaration info]
---   | Lambda    info [VarDecl info] (Type info) (Expr info)
---   | ForBox    info (Name info) (Maybe (Name info)) Text (Expr info) (Expr info)
---   | MapPatch  info (QualifiedName info) [MapBinding info]
---   | SetPatch  info (QualifiedName info) [Expr info]
---   | RecordUpd info (QualifiedName info) [FieldAssignment info]
---   | WrongExpr      Error
-
-instance HasErrors (Alt i) where
-  errors = \case
-    Alt _ a b -> errors a <> errors b
-    WrongAlt e -> return e
-
--- data Alt info
---   = Alt info (Pattern info) (Expr info)
---   | WrongAlt Error
-
-instance HasErrors (LHS i) where
-  errors = \case
-    LHS _ a b -> errors a <> errors b
-    WrongLHS e -> return e
-
--- data LHS info
---   = LHS info (QualifiedName info) (Maybe (Expr info))
---   | WrongLHS Error
-
-instance HasErrors (MapBinding i) where
-  errors = \case
-    MapBinding _ a b -> errors a <> errors b
-    WrongMapBinding e -> return e
-
--- data MapBinding info
---   = MapBinding info (Expr info) (Expr info)
---   | WrongMapBinding Error
-
-instance HasErrors (Assignment i) where
-  errors = \case
-    Assignment _ a b -> errors a <> errors b
-    WrongAssignment e -> return e
-
--- data Assignment info
---   = Assignment info (Name info) (Expr info)
---   | WrongAssignment Error
-
-instance HasErrors (FieldAssignment i) where
-  errors = \case
-    FieldAssignment _ a b -> errors a <> errors b
-    WrongFieldAssignment e -> return e
-
--- data FieldAssignment info
---   = FieldAssignment info (QualifiedName info) (Expr info)
---   | WrongFieldAssignment Error
-
-instance HasErrors (Constant i) where
-  errors = \case
-    WrongConstant e -> return e
-    _ -> fail "none"
-
--- data Constant info
---   = Int     info Text
---   | Nat     info Text
---   | String  info Text
---   | Float   info Text
---   | Bytes   info Text
---   | Tez     info Text
---   | WrongConstant Error
-
-instance HasErrors (Pattern i) where
-  errors = \case
-    IsConstr _ a b -> errors a <> errors b
-    IsConstant _ c -> errors c
-    IsVar _ a -> errors a
-    IsCons _ a b -> errors a <> errors b
-    IsWildcard _ -> fail "none"
-    IsList _ l -> errors l
-    IsTuple _ l -> errors l
-    WrongPattern e -> return e
-
--- data Pattern info
---   = IsConstr     info (Name info) (Maybe (Pattern info))
---   | IsConstant   info (Constant info)
---   | IsVar        info (Name info)
---   | IsCons       info (Pattern info) (Pattern info)
---   | IsWildcard   info
---   | IsList       info [Pattern info]
---   | IsTuple      info [Pattern info]
---   | WrongPattern      Error
-
-instance HasErrors (QualifiedName i) where
-  errors = \case
-    QualifiedName _ a b -> errors a <> errors b
-    WrongQualifiedName e -> return e
-
--- data QualifiedName info
---   = QualifiedName
---     { qnInfo   :: info
---     , qnSource :: Name info
---     , qnPath   :: [Path info]
---     }
---   | WrongQualifiedName Error
-
-instance HasErrors (Path i) where
-  errors = \case
-    At _ a -> errors a
-    Ix _ _ -> fail "none"
-    WrongPath e -> return e
-
--- data Path info
---   = At info (Name info)
---   | Ix info Text
---   | WrongPath Error
-
-instance HasErrors (Name i) where
-  errors = \case
-    WrongName e -> return e
-    _ -> fail "none"
-
--- data Name info = Name
---   { info    :: info
---   , raw     :: Text
---   }
---   | WrongName Error

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

@@ -18,408 +18,311 @@ import Data.Void
 import Parser
 import ParseTree
 import Pretty
+import Tree
 
 import TH
 
 import Debug.Trace
 
-data Contract info
+data Contract it
-  = Contract      info [Declaration info]
+  = Contract      [it]
-  | WrongContract      Error
+  deriving (Show) via PP (Contract it)
-  deriving (Show) via PP (Contract info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Declaration info
+data Declaration it
-  = ValueDecl info (Binding info)
+  = ValueDecl it     -- Binding
-  | TypeDecl  info (Name info) (Type info)
+  | TypeDecl  it it  -- Name Type
-  | Action    info (Expr info)
+  | Action    it     -- Expr
-  | Include   info Text
+  | Include   Text
-  | WrongDecl      Error
+  deriving (Show) via PP (Declaration it)
-  deriving (Show) via PP (Declaration info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Binding info
+data Binding it
-  = Irrefutable  info (Pattern info) (Expr info)
+  = Irrefutable  it it -- (Pattern) (Expr)
-  | Function     info Bool (Name info) [VarDecl info] (Type info) (Expr info)
+  | Function     Bool it [it] it it -- (Name) [VarDecl] (Type) (Expr)
-  | Var          info (Name info) (Type info) (Expr info)
+  | Var          it it it -- (Name) (Type) (Expr)
-  | Const        info (Name info) (Type info) (Expr info)
+  | Const        it it it -- (Name) (Type) (Expr)
-  | WrongBinding      Error
+  deriving (Show) via PP (Binding it)
-  deriving (Show) via PP (Binding info)
   deriving stock (Functor, Foldable, Traversable)
 
-data VarDecl info
+data VarDecl it
-  = Decl         info (Mutable info) (Name info) (Type info)
+  = Decl         it it it -- (Mutable) (Name) (Type)
-  | WrongVarDecl      Error
+  deriving (Show) via PP (VarDecl it)
-  deriving (Show) via PP (VarDecl info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Mutable info
+data Mutable it
-  = Mutable      info
+  = Mutable
-  | Immutable    info
+  | Immutable
-  | WrongMutable      Error
+  deriving (Show) via PP (Mutable it)
-  deriving (Show) via PP (Mutable info)
   deriving stock (Functor, Foldable, Traversable)
 
 
-data Type info
+data Type it
-  = TArrow    info  (Type info) (Type info)
+  = TArrow    it it -- (Type) (Type)
-  | TRecord   info [TField info]
+  | TRecord   [it] -- [TField]
-  | TVar      info  (Name info)
+  | TVar      it -- (Name)
-  | TSum      info [Variant info]
+  | TSum      [it] -- [Variant]
-  | TProduct  info  [Type info]
+  | TProduct  [it] -- [Type]
-  | TApply    info  (Name info) [Type info]
+  | TApply    it [it] -- (Name) [Type]
-  | WrongType      Error
+  deriving (Show) via PP (Type it)
-  deriving (Show) via PP (Type info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Variant info
+data Variant it
-  = Variant info (Name info) (Maybe (Type info))
+  = Variant it (Maybe it) -- (Name) (Maybe (Type))
-  | WrongVariant Error
+  deriving (Show) via PP (Variant it)
-  deriving (Show) via PP (Variant info)
   deriving stock (Functor, Foldable, Traversable)
 
-data TField info
+data TField it
-  = TField info (Name info) (Type info)
+  = TField it it -- (Name) (Type)
-  | WrongTField Error
+  deriving (Show) via PP (TField it)
-  deriving (Show) via PP (TField info)
   deriving stock (Functor, Foldable, Traversable)
 
 -- | TODO: break onto smaller types? Literals -> Constannt; mapOps; mmove Annots to Decls.
-data Expr info
+data Expr it
-  = Let       info [Declaration info] (Expr info)
+  = Let       [it] it -- [Declaration] (Expr)
-  | Apply     info (Expr info) [Expr info]
+  | Apply     it [it] -- (Expr) [Expr]
-  | Constant  info (Constant info)
+  | Constant  it -- (Constant)
-  | Ident     info (QualifiedName info)
+  | Ident     it -- (QualifiedName)
-  | BinOp     info (Expr info) Text (Expr info)
+  | BinOp     it Text it -- (Expr) Text (Expr)
-  | UnOp      info Text (Expr info)
+  | UnOp      Text it -- (Expr)
-  | Record    info [Assignment info]
+  | Record    [it] -- [Assignment]
-  | If        info (Expr info) (Expr info) (Expr info)
+  | If        it it it -- (Expr) (Expr) (Expr)
-  | Assign    info (LHS info) (Expr info)
+  | Assign    it it -- (LHS) (Expr)
-  | List      info [Expr info]
+  | List      [it] -- [Expr]
-  | Set       info [Expr info]
+  | Set       [it] -- [Expr]
-  | Tuple     info [Expr info]
+  | Tuple     [it] -- [Expr]
-  | Annot     info (Expr info) (Type info)
+  | Annot     it it -- (Expr) (Type)
-  | Attrs     info [Text]
+  | Attrs     [Text]
-  | BigMap    info [MapBinding info]
+  | BigMap    [it] -- [MapBinding]
-  | Map       info [MapBinding info]
+  | Map       [it] -- [MapBinding]
-  | MapRemove info (Expr info) (QualifiedName info)
+  | MapRemove it it -- (Expr) (QualifiedName)
-  | SetRemove info (Expr info) (QualifiedName info)
+  | SetRemove it it -- (Expr) (QualifiedName)
-  | Indexing  info (QualifiedName info) (Expr info)
+  | Indexing  it it -- (QualifiedName) (Expr)
-  | Case      info (Expr info) [Alt info]
+  | Case      it [it] -- (Expr) [Alt]
-  | Skip      info
+  | Skip
-  | ForLoop   info (Name info) (Expr info) (Expr info) (Expr info)
+  | ForLoop   it it it it -- (Name) (Expr) (Expr) (Expr)
-  | WhileLoop info (Expr info) (Expr info)
+  | WhileLoop it it -- (Expr) (Expr)
-  | Seq       info [Declaration info]
+  | Seq       [it] -- [Declaration]
-  | Lambda    info [VarDecl info] (Type info) (Expr info)
+  | Lambda    [it] it it -- [VarDecl] (Type) (Expr)
-  | ForBox    info (Name info) (Maybe (Name info)) Text (Expr info) (Expr info)
+  | ForBox    it (Maybe it) Text it it -- (Name) (Maybe (Name)) Text (Expr) (Expr)
-  | MapPatch  info (QualifiedName info) [MapBinding info]
+  | MapPatch  it [it] -- (QualifiedName) [MapBinding]
-  | SetPatch  info (QualifiedName info) [Expr info]
+  | SetPatch  it [it] -- (QualifiedName) [Expr]
-  | RecordUpd info (QualifiedName info) [FieldAssignment info]
+  | RecordUpd it [it] -- (QualifiedName) [FieldAssignment]
-  | WrongExpr      Error
+  deriving (Show) via PP (Expr it)
-  deriving (Show) via PP (Expr info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Alt info
+data Alt it
-  = Alt info (Pattern info) (Expr info)
+  = Alt it it -- (Pattern) (Expr)
-  | WrongAlt Error
+  deriving (Show) via PP (Alt it)
-  deriving (Show) via PP (Alt info)
   deriving stock (Functor, Foldable, Traversable)
 
-data LHS info
+data LHS it
-  = LHS info (QualifiedName info) (Maybe (Expr info))
+  = LHS it (Maybe it) -- (QualifiedName) (Maybe (Expr))
-  | WrongLHS Error
+  deriving (Show) via PP (LHS it)
-  deriving (Show) via PP (LHS info)
   deriving stock (Functor, Foldable, Traversable)
 
-data MapBinding info
+data MapBinding it
-  = MapBinding info (Expr info) (Expr info)
+  = MapBinding it it -- (Expr) (Expr)
-  | WrongMapBinding Error
+  deriving (Show) via PP (MapBinding it)
-  deriving (Show) via PP (MapBinding info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Assignment info
+data Assignment it
-  = Assignment info (Name info) (Expr info)
+  = Assignment it it -- (Name) (Expr)
-  | WrongAssignment Error
+  deriving (Show) via PP (Assignment it)
-  deriving (Show) via PP (Assignment info)
   deriving stock (Functor, Foldable, Traversable)
 
-data FieldAssignment info
+data FieldAssignment it
-  = FieldAssignment info (QualifiedName info) (Expr info)
+  = FieldAssignment it it -- (QualifiedName) (Expr)
-  | WrongFieldAssignment Error
+  deriving (Show) via PP (FieldAssignment it)
-  deriving (Show) via PP (FieldAssignment info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Constant info
+data Constant it
-  = Int     info Text
+  = Int     Text
-  | Nat     info Text
+  | Nat     Text
-  | String  info Text
+  | String  Text
-  | Float   info Text
+  | Float   Text
-  | Bytes   info Text
+  | Bytes   Text
-  | Tez     info Text
+  | Tez     Text
-  | WrongConstant Error
+  deriving (Show) via PP (Constant it)
-  deriving (Show) via PP (Constant info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Pattern info
+data Pattern it
-  = IsConstr     info (Name info) (Maybe (Pattern info))
+  = IsConstr     it (Maybe it) -- (Name) (Maybe (Pattern))
-  | IsConstant   info (Constant info)
+  | IsConstant   it -- (Constant)
-  | IsVar        info (Name info)
+  | IsVar        it -- (Name)
-  | IsCons       info (Pattern info) (Pattern info)
+  | IsCons       it it -- (Pattern) (Pattern)
-  | IsWildcard   info
+  | IsWildcard
-  | IsList       info [Pattern info]
+  | IsList       [it] -- [Pattern]
-  | IsTuple      info [Pattern info]
+  | IsTuple      [it] -- [Pattern]
-  | WrongPattern      Error
+  deriving (Show) via PP (Pattern it)
-  deriving (Show) via PP (Pattern info)
   deriving stock (Functor, Foldable, Traversable)
 
-data QualifiedName info
+data QualifiedName it
   = QualifiedName
-    { qnInfo   :: info
+    { qnSource :: it -- Name
-    , qnSource :: Name info
+    , qnPath   :: [it] -- [Path]
-    , qnPath   :: [Path info]
     }
-  | WrongQualifiedName Error
+  deriving (Show) via PP (QualifiedName it)
-  deriving (Show) via PP (QualifiedName info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Path info
+data Path it
-  = At info (Name info)
+  = At it -- (Name)
-  | Ix info Text
+  | Ix Text
-  | WrongPath Error
+  deriving (Show) via PP (Path it)
-  deriving (Show) via PP (Path info)
   deriving stock (Functor, Foldable, Traversable)
 
-data Name info = Name
+data Name it = Name
-  { _info    :: info
+  { _raw     :: Text
-  , _raw     :: Text
   }
-  | WrongName Error
+  deriving (Show) via PP (Name it)
-  deriving (Show) via PP (Name info)
   deriving stock (Functor, Foldable, Traversable)
 
-c :: HasComments i => i -> Doc -> Doc
+instance Pretty1 Contract where
-c i d =
+  pp1 = \case
-  case getComments i of
+    Contract decls ->
-    [] -> d
-    cc -> block (map removeSlashN cc) $$ d
-  where
-    removeSlashN txt =
-      if "\n" `Text.isSuffixOf` txt
-      then Text.init txt
-      else txt
-
-instance HasComments i => Pretty (Contract i) where
-  pp = \case
-    Contract i decls -> c i $
       sparseBlock decls
 
-    WrongContract err ->
+instance Pretty1 Declaration where
-      pp err
+  pp1 = \case
+    ValueDecl binding -> binding
+    TypeDecl  n ty    -> "type" <+> n <+> "=" `indent` ty
+    Action    e       -> e
+    Include   f       -> "#include" <+> pp f
 
-instance HasComments i => Pretty (Declaration i) where
+instance Pretty1 Binding where
-  pp = \case
+  pp1 = \case
-    ValueDecl i binding -> c i $ pp binding
+    Irrefutable  pat expr -> error "irrefs in pascaligo?"
-    TypeDecl  i n ty    -> c i $ "type" <+> pp n <+> "=" `indent` pp ty
+    Function     isRec name params ty body ->
-    Action    i e       -> c i $ pp e
+      (
-    Include   i f       -> c i $ "#include" <+> pp f
-    WrongDecl err       ->       pp err
-
-instance HasComments i => Pretty (Binding i) where
-  pp = \case
-    Irrefutable  i pat expr -> error "irrefs in pascaligo?"
-    Function     i isRec name params ty body ->
-      c i $
         (
-          (
+          (   (if isRec then "recursive" else empty)
-            (   (if isRec then "recursive" else empty)
+          <+> "function"
-            <+> "function"
+          <+> name
-            <+> pp name
-            )
-            `indent` tuple params
           )
-         `indent` (":" <+> pp ty <+> "is")
+          `indent` tuple params
         )
-        `indent` pp body
+        `indent` (":" <+> ty <+> "is")
-    Var   i name ty value -> c i $ "var"   <+> pp name <+> ":" <+> pp ty <+> ":=" `indent` pp value
+      )
-    Const i name ty body  -> c i $ "const" <+> pp name <+> ":" <+> pp ty <+>  "=" `indent` pp body
+      `indent` body
-    WrongBinding err ->
+    Var   name ty value -> "var"   <+> name <+> ":" <+> ty <+> ":=" `indent` value
-      pp err
+    Const name ty body  -> "const" <+> name <+> ":" <+> ty <+>  "=" `indent` body
 
-instance HasComments i => Pretty (VarDecl i) where
+instance Pretty1 VarDecl where
-  pp = \case
+  pp1 = \case
-    Decl i mutability name ty -> c i $
+    Decl mutability name ty -> mutability <+> name <+> ":" `indent` ty
-      pp mutability <+> pp name <+> ":" `indent` pp ty
-    WrongVarDecl err ->
-      pp err
 
-instance HasComments i => Pretty (Mutable i) where
+instance Pretty1 Mutable where
-  pp = \case
+  pp1 = \case
-    Mutable      i   -> c i $ "var"
+    Mutable          -> "var"
-    Immutable    i   -> c i $ "const"
+    Immutable        -> "const"
-    WrongMutable err -> pp err
 
-instance HasComments i => Pretty (Type i) where
+instance Pretty1 Type where
-  pp = \case
+  pp1 = \case
-    TArrow    i dom codom -> c i $ parens (pp dom `indent` "->" <+> pp codom)
+    TArrow    dom codom -> parens (dom `indent` "->" <+> codom)
-    TRecord   i fields    -> c i $ "record [" `indent` block fields `above` "]"
+    TRecord   fields    -> "record [" `indent` block fields `above` "]"
-    TVar      i name      -> c i $ pp name
+    TVar      name      -> name
-    TSum      i variants  -> c i $ block variants
+    TSum      variants  -> block variants
-    TProduct  i elements  -> c i $ train " *" elements
+    TProduct  elements  -> train " *" elements
-    TApply    i f xs      -> c i $ pp f <> tuple xs
+    TApply    f xs      -> f <> tuple xs
-    WrongType   err       ->       pp err
     where
-      ppField (name, ty) = pp name <> ": " <> pp ty <> ";"
+      ppField (name, ty) = name <> ": " <> ty <> ";"
 
-instance HasComments i => Pretty (Variant i) where
+instance Pretty1 Variant where
-  pp = \case
+  pp1 = \case
-    Variant i ctor (Just ty) -> c i $ "|" <+> pp ctor <+> "of" `indent` pp ty
+    Variant ctor (Just ty) -> "|" <+> ctor <+> "of" `indent` ty
-    Variant i ctor  _        -> c i $ "|" <+> pp ctor
+    Variant ctor  _        -> "|" <+> ctor
-    WrongVariant err -> pp err
 
--- My eyes.
+instance Pretty1 Expr where
-instance HasComments i => Pretty (Expr i) where
+  pp1 = \case
-  pp = \case
+    Let       decls body -> "block {" `indent` sparseBlock decls `above` "}" <+> "with" `indent` body
-    Let       i decls body -> c i $ "block {" `indent` sparseBlock decls `above` "}" <+> "with" `indent` pp body
+    Apply     f xs       -> f <+> tuple xs
-    Apply     i f xs       -> c i $ pp f <+> tuple xs
+    Constant  constant   -> constant
-    Constant  i constant   -> c i $ pp constant
+    Ident     qname      -> qname
-    Ident     i qname      -> c i $ pp qname
+    BinOp     l o r      -> parens (l <+> pp o <+> r)
-    BinOp     i l o r      -> c i $ parens (pp l <+> pp o <+> pp r)
+    UnOp        o r      -> parens (pp o <+> r)
-    UnOp      i   o r      -> c i $ parens (pp o <+> pp r)
+    Record    az         -> "record" <+> list az
-    Record    i az         -> c i $ "record" <+> list az
+    If        b t e      -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e]
-    If        i b t e      -> c i $ fsep ["if" `indent` pp b, "then" `indent` pp t, "else" `indent` pp e]
+    Assign    l r        -> l <+> ":=" `indent` r
-    Assign    i l r        -> c i $ pp l <+> ":=" `indent` pp r
+    List      l          -> "list" <+> list l
-    List      i l          -> c i $ "list" <+> list l
+    Set       l          -> "set"  <+> list l
-    Set       i l          -> c i $ "set"  <+> list l
+    Tuple     l          -> tuple l
-    Tuple     i l          -> c i $ tuple l
+    Annot     n t        -> parens (n <+> ":" `indent` t)
-    Annot     i n t        -> c i $ parens (pp n <+> ":" `indent` pp t)
+    Attrs     ts         -> "attributes" <+> list ts
-    Attrs     i ts         -> c i $ "attributes" <+> list ts
+    BigMap    bs         -> "big_map"    <+> list bs
-    BigMap    i bs         -> c i $ "big_map"    <+> list bs
+    Map       bs         ->  "map"       <+> list bs
-    Map       i bs         -> c i $  "map"       <+> list bs
+    MapRemove k m        -> "remove" `indent` k `above` "from" <+> "map" `indent` m
-    MapRemove i k m        -> c i $ "remove" `indent` pp k `above` "from" <+> "map" `indent` pp m
+    SetRemove k s        -> "remove" `indent` k `above` "from" <+> "set" `indent` s
-    SetRemove i k s        -> c i $ "remove" `indent` pp k `above` "from" <+> "set" `indent` pp s
+    Indexing  a j        -> a <> list [j]
-    Indexing  i a j        -> c i $ pp a <> list [j]
+    Case      s az       -> "case" <+> s <+> "of" `indent` block az
-    Case      i s az       -> c i $ "case" <+> pp s <+> "of" `indent` block az
+    Skip                 -> "skip"
-    Skip      i            -> c i $ "skip"
+    ForLoop   j s f b    -> "for" <+> j <+> ":=" <+> s <+> "to" <+> f `indent` b
-    ForLoop   i j s f b    -> c i $ "for" <+> pp j <+> ":=" <+> pp s <+> "to" <+> pp f `indent` pp b
+    ForBox    k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b
-    ForBox    i k mv t z b -> c i $ "for" <+> pp k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> pp z `indent` pp b
+    WhileLoop f b        -> "while" <+> f `indent` b
-    WhileLoop i f b        -> c i $ "while" <+> pp f `indent` pp b
+    Seq       es         -> "block {" `indent` sparseBlock es `above` "}"
-    Seq       i es         -> c i $ "block {" `indent` sparseBlock es `above` "}"
+    Lambda    ps ty b    -> (("function" `indent` tuple ps) `indent` (":" <+> ty)) `indent` b
-    Lambda    i ps ty b    -> c i $ (("function" `indent` tuple ps) `indent` (":" <+> pp ty)) `indent` pp b
+    MapPatch  z bs       -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs
-    MapPatch  i z bs       -> c i $ "patch" `indent` pp z `above` "with" <+> "map" `indent` list bs
+    SetPatch  z bs       -> "patch" `indent` z `above` "with" <+> "set" `indent` list bs
-    SetPatch  i z bs       -> c i $ "patch" `indent` pp z `above` "with" <+> "set" `indent` list bs
+    RecordUpd r up       -> r `indent` "with" <+> "record" `indent` list up
-    RecordUpd i r up       -> c i $ pp r `indent` "with" <+> "record" `indent` list up
-    WrongExpr   err        -> pp err
 
-instance HasComments i => Pretty (Alt i) where
+instance Pretty1 Alt where
-  pp = \case
+  pp1 = \case
-    Alt i p b -> c i $ "|" <+> pp p <+> "->" `indent` pp b
+    Alt p b -> "|" <+> p <+> "->" `indent` b
-    WrongAlt err -> pp err
 
-instance HasComments i => Pretty (MapBinding i) where
+instance Pretty1 MapBinding where
-  pp = \case
+  pp1 = \case
-    MapBinding i k v -> c i $ pp k <+> "->" `indent` pp v
+    MapBinding k v -> k <+> "->" `indent` v
-    WrongMapBinding err -> pp err
 
-instance HasComments i => Pretty (Assignment i) where
+instance Pretty1 Assignment where
-  pp = \case
+  pp1 = \case
-    Assignment      i n e -> c i $ pp n <+> "=" `indent` pp e
+    Assignment      n e -> n <+> "=" `indent` e
-    WrongAssignment   err -> pp err
 
-instance HasComments i => Pretty (FieldAssignment i) where
+instance Pretty1 FieldAssignment where
-  pp = \case
+  pp1 = \case
-    FieldAssignment      i n e -> c i $ pp n <+> "=" `indent` pp e
+    FieldAssignment      n e -> n <+> "=" `indent` e
-    WrongFieldAssignment   err -> pp err
 
-instance HasComments i => Pretty (Constant i) where
+instance Pretty1 Constant where
-  pp = \case
+  pp1 = \case
-    Int           i z   -> c i $ pp z
+    Int           z   -> pp z
-    Nat           i z   -> c i $ pp z
+    Nat           z   -> pp z
-    String        i z   -> c i $ pp z
+    String        z   -> pp z
-    Float         i z   -> c i $ pp z
+    Float         z   -> pp z
-    Bytes         i z   -> c i $ pp z
+    Bytes         z   -> pp z
-    Tez           i z   -> c i $ pp z
+    Tez           z   -> pp z
-    WrongConstant   err -> pp err
 
-instance HasComments i => Pretty (QualifiedName i) where
+instance Pretty1 QualifiedName where
-  pp = \case
+  pp1 = \case
-    QualifiedName i src path -> c i $ pp src <> sepByDot path
+    QualifiedName src path -> src <> sepByDot path
-    WrongQualifiedName err   -> pp err
 
-instance HasComments i => Pretty (Pattern i) where
+instance Pretty1 Pattern where
-  pp = \case
+  pp1 = \case
-    IsConstr     i ctor arg  -> c i $ pp ctor <+> maybe empty pp arg
+    IsConstr     ctor arg  -> ctor <+> maybe empty id arg
-    IsConstant   i z         -> c i $ pp z
+    IsConstant   z         -> z
-    IsVar        i name      -> c i $ pp name
+    IsVar        name      -> name
-    IsCons       i h t       -> c i $ pp h <+> ("#" <+> pp t)
+    IsCons       h t       -> h <+> ("#" <+> t)
-    IsWildcard   i           -> c i $ "_"
+    IsWildcard             -> "_"
-    IsList       i l         -> c i $ list l
+    IsList       l         -> list l
-    IsTuple      i t         -> c i $ tuple t
+    IsTuple      t         -> tuple t
-    WrongPattern   err       -> pp err
 
 
-instance HasComments i => Pretty (Name i) where
+instance Pretty1 Name where
-  pp = \case
+  pp1 = \case
-    Name      i raw -> c i $ pp raw
+    Name      raw -> pp raw
-    WrongName err   -> pp err
 
-instance HasComments i => Pretty (Path i) where
+instance Pretty1 Path where
-  pp = \case
+  pp1 = \case
-    At i n -> c i $ pp n
+    At n -> n
-    Ix i j -> c i $ pp j
+    Ix j -> pp j
-    WrongPath err -> pp err
 
-instance HasComments i => Pretty (TField i) where
+instance Pretty1 TField where
-  pp = \case
+  pp1 = \case
-    TField i n t -> c i $ pp n <> ":" `indent` pp t
+    TField      n t -> n <> ":" `indent` t
-    WrongTField err -> pp err
 
-instance HasComments i => Pretty (LHS i) where
+instance Pretty1 LHS where
-  pp = \case
+  pp1 = \case
-    LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi
+    LHS    qn mi -> qn <> foldMap brackets mi
-    WrongLHS err -> pp err
 
-foldMap makePrisms
+type Pascal = Tree
-  [ ''Name
+  [ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
-  , ''Path
+  , MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
-  , ''QualifiedName
+  , Declaration, Contract
-  , ''Pattern
-  , ''Constant
-  , ''FieldAssignment
-  , ''Assignment
-  , ''MapBinding
-  , ''LHS
-  , ''Alt
-  , ''Expr
-  , ''TField
-  , ''Variant
-  , ''Type
-  , ''Mutable
-  , ''VarDecl
-  , ''Binding
-  , ''Declaration
-  , ''Contract
   ]
-
-foldMap makeLenses
-  [ ''Name
-  ]
-
-instance Stubbed (Name info) where stubbing = _WrongName
-instance Stubbed (Path info) where stubbing = _WrongPath
-instance Stubbed (QualifiedName info) where stubbing = _WrongQualifiedName
-instance Stubbed (Pattern info) where stubbing = _WrongPattern
-instance Stubbed (Constant info) where stubbing = _WrongConstant
-instance Stubbed (FieldAssignment info) where stubbing = _WrongFieldAssignment
-instance Stubbed (Assignment info) where stubbing = _WrongAssignment
-instance Stubbed (MapBinding info) where stubbing = _WrongMapBinding
-instance Stubbed (LHS info) where stubbing = _WrongLHS
-instance Stubbed (Alt info) where stubbing = _WrongAlt
-instance Stubbed (Expr info) where stubbing = _WrongExpr
-instance Stubbed (TField info) where stubbing = _WrongTField
-instance Stubbed (Variant info) where stubbing = _WrongVariant
-instance Stubbed (Type info) where stubbing = _WrongType
-instance Stubbed (Mutable info) where stubbing = _WrongMutable
-instance Stubbed (VarDecl info) where stubbing = _WrongVarDecl
-instance Stubbed (Binding info) where stubbing = _WrongBinding
-instance Stubbed (Declaration info) where stubbing = _WrongDecl
-instance Stubbed (Contract info) where stubbing = _WrongContract

tools/lsp/squirrel/src/Error.hs

@@ -0,0 +1,20 @@
+
+module Error where
+
+import Data.Text (Text)
+
+import Pretty
+import Range
+
+-- | Parse error.
+data Error
+  = Expected
+    { eMsg   :: Text   -- ^ Description of what was expected.
+    , eWhole :: Text   -- ^ Offending text.
+    , eRange :: Range  -- ^ Location of the error.
+    }
+  deriving (Show) via PP Error
+
+instance Pretty Error where
+  pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓"
+

tools/lsp/squirrel/src/HasComments.hs

@@ -0,0 +1,23 @@
+
+module HasComments where
+
+import qualified Data.Text as Text
+
+import Pretty
+
+class HasComments c where
+  getComments :: c -> [Text.Text]
+
+c :: HasComments i => i -> Doc -> Doc
+c i d =
+  case getComments i of
+    [] -> d
+    cc -> block (map removeSlashN cc) $$ d
+  where
+    removeSlashN txt =
+      if "\n" `Text.isSuffixOf` txt
+      then Text.init txt
+      else txt
+
+instance HasComments () where
+  getComments () = []

tools/lsp/squirrel/src/HasErrors.hs

@@ -0,0 +1,6 @@
+module HasErrors where
+
+import Error
+
+class HasErrors h where
+  errors :: h -> [Error]

tools/lsp/squirrel/src/Lattice.hs

@@ -0,0 +1,11 @@
+
+module Lattice where
+
+class Lattice l where
+  (?>) :: l -> l -> Bool
+  (<?) :: l -> l -> Bool
+
+  (?>) = flip (<?)
+  (<?) = flip (?>)
+
+  {-# minimal (?>) | (<?) #-}

tools/lsp/squirrel/src/Parser.hs

@@ -44,8 +44,8 @@ module Parser
   , subtree
   , anything
   , token
-  , ASTInfo
+  , ASTInfo(..)
-  , ctor
+  , getInfo
   , inside
   , many
   , some
@@ -56,7 +56,6 @@ module Parser
   , stubbed
   , Stubbed (..)
   , Error (..)
-  , HasComments (getComments)
   ) where
 
 import Control.Lens hiding (inside)
@@ -78,21 +77,12 @@ import Data.ByteString (ByteString)
 import ParseTree
 import Range
 import Pretty
+import HasComments
+import Error
+import Stubbed
 
 import Debug.Trace
 
--- | Parse error.
-data Error
-  = Expected
-    { eMsg   :: Text   -- ^ Description of what was expected.
-    , eWhole :: Text   -- ^ Offending text.
-    , eRange :: Range  -- ^ Location of the error.
-    }
-  deriving (Show) via PP Error
-
-instance Pretty Error where
-  pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓"
-
 -- | Parser of tree-sitter-made tree.
 --
 --   TODO: separate state. Polysemy?
@@ -117,13 +107,13 @@ newtype Parser a = Parser
 -- | Generate error originating at current location.
 makeError :: Text -> Parser Error
 makeError msg = do
-  rng <- getRange
+  rng <- currentRange
   makeError' msg rng
 
 -- | Generate error originating at given location.
 makeError' :: Text -> Range -> Parser Error
 makeError' msg rng = do
-  rng <- getRange
+  rng <- currentRange
   src <- gets (pfGrove . fst) <&> \case
     []                     -> ""
     (,) _ ParseTree { ptSource } : _ -> ptSource
@@ -343,8 +333,8 @@ range parser =
       return (a, pfRange)
 
 -- | Get current range.
-getRange :: Parser Range
+currentRange :: Parser Range
-getRange = snd <$> range (return ())
+currentRange = snd <$> range (return ())
 
 -- | Remove all keys until given key is found; remove the latter as well.
 --
@@ -392,26 +382,7 @@ notFollowedBy parser = do
     die "notFollowedBy"
 
 stub :: Stubbed a => Error -> a
-stub = (stubbing #)
+stub = stubbing
-
--- | For types that have a default replacer with an `Error`.
-class Stubbed a where
-  stubbing :: Prism' a Error
-
-instance Stubbed Text where
-  stubbing = prism (pack . show) Left
-
--- | This is bad, but I had to.
---
---   TODO: Find a way to remove this instance.
---         I probably need a wrapper around '[]'.
---
-instance Stubbed [a] where
-  stubbing = prism (const []) Left
-
--- | `Nothing` would be bad default replacer.
-instance Stubbed a => Stubbed (Maybe a) where
-  stubbing = _Just . stubbing
 
 -- | Universal accessor.
 --
@@ -447,15 +418,15 @@ data ASTInfo = ASTInfo
   , aiComments :: [Text]
   }
 
-class HasComments c where
-  getComments :: c -> [Text]
-
 instance HasComments ASTInfo where
   getComments = aiComments
 
+instance HasRange ASTInfo where
+  getRange = aiRange
+
 -- | Equip given constructor with info.
-ctor :: (ASTInfo -> a) -> Parser a
+getInfo :: Parser ASTInfo
-ctor = (<$> (ASTInfo <$> getRange <*> grabComments))
+getInfo = ASTInfo <$> currentRange <*> grabComments
 
 grabComments :: Parser [Text]
 grabComments = do

tools/lsp/squirrel/src/Pretty.hs

@@ -9,10 +9,13 @@ module Pretty
   where
 
 import qualified Data.Text as Text
-import Data.Text (Text)
+import Data.Text (Text, pack)
 
 import Text.PrettyPrint hiding ((<>))
 
+ppToText :: Pretty a => a -> Text
+ppToText = pack . show . pp
+
 -- | With this, one can `data X = ...; derive Show via PP X`
 newtype PP a = PP { unPP :: a }
 
@@ -23,10 +26,20 @@ instance Pretty a => Show (PP a) where
 class Pretty p where
   pp :: p -> Doc
 
+class Pretty1 p where
+  pp1 :: p Doc -> Doc
+
+instance (Pretty1 p, Functor p, Pretty a) => Pretty (p a) where
+  pp = pp1 . fmap pp
+
 -- | Common instance.
 instance Pretty Text where
   pp = text . Text.unpack
 
+-- | Common instance.
+instance Pretty Doc where
+  pp = id
+
 tuple :: Pretty p => [p] -> Doc
 tuple = parens . train ","
 

tools/lsp/squirrel/src/Range.hs

@@ -22,4 +22,4 @@ instance Pretty Range where
       int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc
 
 class HasRange a where
-  location :: Lens' a Range
+  getRange :: a -> Range

tools/lsp/squirrel/src/Stubbed.hs

@@ -0,0 +1,28 @@
+
+module Stubbed where
+
+import Control.Lens
+
+import Data.Text (Text, pack)
+
+import Error
+
+-- | For types that have a default replacer with an `Error`.
+class Stubbed a where
+  stubbing :: Error -> a
+
+instance Stubbed Text where
+  stubbing = pack . show
+
+-- | This is bad, but I had to.
+--
+--   TODO: Find a way to remove this instance.
+--         I probably need a wrapper around '[]'.
+--
+instance Stubbed [a] where
+  stubbing = const []
+
+-- | `Nothing` would be bad default replacer.
+instance Stubbed a => Stubbed (Maybe a) where
+  stubbing = Just . stubbing
+

tools/lsp/squirrel/src/Tree.hs

@@ -0,0 +1,105 @@
+
+module Tree where
+
+import Data.Fix
+import Data.Functor.Compose
+
+import Union
+import Update
+import Lattice
+import HasComments
+import HasErrors
+import Pretty
+import Error
+import Stubbed
+
+-- | Tree is a fixpoint of `Union` @layers@, each equipped with an @info@.
+newtype Tree layers info = Tree
+  { unTree :: Fix (Either Error `Compose` (,) info `Compose` Union layers)
+  }
+
+instance (Functor (Union layers)) => Functor (Tree layers) where
+  fmap f (Tree fixpoint) = Tree $ cata (Fix . go) fixpoint
+    where
+      go (Compose (Left err)) = Compose $ Left err
+      go (Compose (Right (Compose (a, rest)))) =
+        Compose $ Right $ Compose (f a, rest)
+
+instance
+    ( Functor (Union layers)
+    , HasComments info
+    , Pretty  (Union layers Doc)
+    )
+  =>
+    Show (Tree layers info)
+  where
+    show = show . pp
+
+instance {-# OVERLAPS #-}
+    ( HasComments info
+    , Functor (Union fs)
+    , Pretty  (Union fs Doc)
+    )
+  =>
+    Pretty (Tree fs info)
+  where
+    pp (Tree it) = cata aux it
+      where
+        aux (Compose (Left err)) = pp err
+        aux (Compose (Right (Compose (info, fTree)))) = c info $ pp fTree
+
+-- Return all subtrees that cover the range, ascending in side.
+spineTo
+  :: ( Lattice   info
+     , Foldable (Union fs)
+     )
+  => info
+  -> Tree fs info
+  -> [Tree fs info]
+spineTo info = reverse . go . unTree
+  where
+    go tree@(Fix (Compose (Right (Compose (info', fres))))) =
+      -- traceShow (info <? info', info, info') $
+      if   info <? info'
+      then Tree tree : foldMap go fres
+      else []
+
+    go _ = []
+
+-- | Update the tree in the monad that exports its methods.
+updateTree
+  :: ( UpdateOver m (Union fs) (Tree fs a)
+     , Traversable  (Union fs)
+     )
+  => (a -> m b)
+  -> Tree fs a -> m (Tree fs b)
+updateTree act = fmap Tree . go . unTree
+  where
+    go (Fix (Compose (Right (Compose (a, union))))) = do
+      b <- act a
+      before (Tree <$> union)
+      union' <- traverse go union
+      after (Tree <$> union)
+      return (Fix (Compose (Right (Compose (b, union')))))
+
+    go (Fix (Compose (Left err))) = do
+      return (Fix (Compose (Left err)))
+
+-- | Make a tree out of a layer and an info.
+mk :: (Functor f, Member f fs) => info -> f (Tree fs info) -> Tree fs info
+mk i fx = Tree $ Fix $ Compose $ Right $ Compose (i, inj $ fmap unTree fx)
+
+infoOf :: Tree fs info -> Maybe info
+infoOf (Tree (Fix (Compose it))) =
+  either
+    (const Nothing)
+    (Just . fst . getCompose) it
+
+instance Stubbed (Tree fs info) where
+  stubbing = Tree . Fix . Compose . Left
+
+instance Foldable (Union fs) => HasErrors (Tree fs info) where
+  errors = go . unTree
+    where
+      go (Fix (Compose (Left err))) = pure err
+      go (Fix rest)                 = foldMap go rest

tools/lsp/squirrel/src/Union.hs

@@ -0,0 +1,77 @@
+
+module Union
+  ( Union(..), eliminate
+  , Member, proj, inj
+  )
+  where
+
+import Update
+import Pretty
+
+{-
+  The "one of" datatype.
+  Each `Union fs a` is a `f a`, where `f` is one of `fs`.
+-}
+data Union fs x where
+  Here  ::       f  x -> Union (f : fs) x
+  There :: Union fs x -> Union (f : fs) x
+
+instance Eq          (Union '[] a) where (==)     = error "Union.empty"
+instance Show        (Union '[] a) where show     = error "Union.empty"
+
+instance Functor     (Union '[])   where fmap     = error "Union.empty"
+instance Foldable    (Union '[])   where foldMap  = error "Union.empty"
+instance Traversable (Union '[])   where traverse = error "Union.empty"
+
+instance (Eq (f a), Eq (Union fs a)) => Eq (Union (f : fs) a) where
+  a == b = case (a, b) of
+    (Here  a', Here  b') -> a' == b'
+    (There a', There b') -> a' == b'
+    _                    -> False
+
+instance (Show (f a), Show (Union fs a)) => Show (Union (f : fs) a) where
+  show = eliminate show show
+
+deriving stock instance (Functor     f, Functor     (Union fs)) => Functor     (Union (f : fs))
+deriving stock instance (Foldable    f, Foldable    (Union fs)) => Foldable    (Union (f : fs))
+deriving stock instance (Traversable f, Traversable (Union fs)) => Traversable (Union (f : fs))
+
+{-
+  A case over `Union`.
+-}
+eliminate
+  :: (f x -> a)
+  -> (Union fs x -> a)
+  -> (Union (f : fs) x -> a)
+eliminate here there = \case
+  Here  fx   -> here fx
+  There rest -> there rest
+
+{-
+  The `f` functior is in the `fs` list.
+-}
+class Member f fs where
+  inj  :: f x -> Union fs x          -- embed f into some Union
+  proj :: Union fs x -> Maybe (f x)  -- check if a Union is actually f
+
+instance {-# OVERLAPS #-} Member f (f : fs) where
+  inj  = Here
+  proj = eliminate Just (const Nothing)
+
+instance Member f fs => Member f (g : fs) where
+  inj  = There . inj
+  proj = eliminate (const Nothing) proj
+
+instance HasMethods m => UpdateOver m (Union '[]) a where
+  before = error "Union.empty"
+  after  = error "Union.empty"
+
+instance (HasMethods m, UpdateOver m f a, UpdateOver m (Union fs) a) => UpdateOver m (Union (f : fs)) a where
+  before = eliminate before before
+  after  = eliminate after  after
+
+instance Pretty1 (Union '[]) where
+  pp1 = error "Union.empty"
+
+instance (Pretty1 f, Pretty1 (Union fs)) => Pretty1 (Union (f : fs)) where
+  pp1 = eliminate pp1 pp1

tools/lsp/squirrel/src/Update.hs

@@ -0,0 +1,22 @@
+
+module Update where
+
+{-
+  Abstraction over monad capabilities.
+-}
+class Monad m => HasMethods m where
+  data Methods m :: *
+  method :: Methods m
+
+{-
+  Given some AST structure, do some stuff before & after it is traversed.
+-}
+class HasMethods m => UpdateOver m f a where
+  before :: f a -> m ()
+  after  :: f a -> m ()
+
+  before _ = skip
+  after  _ = skip
+
+skip :: Monad m => m ()
+skip = return ()