[LIGO-37] [LIGO-38] Looks like it fixes it

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

@@ -68,13 +68,13 @@ example :: FilePath
 -- example = "../../../src/test/contracts/let_in_multi_bind.mligo"
 example = "../../../src/test/contracts/fibo2.mligo"
 
-raw :: IO ()
-raw = toParseTree (Path example)
-  >>= print . pp
+-- raw :: IO ()
+-- raw = toParseTree (Path example)
+--   >>= print . pp
 
-raw' :: FilePath -> IO ()
-raw' example = toParseTree (Path example)
-  >>= print . pp
+-- raw' :: FilePath -> IO ()
+-- raw' example = toParseTree (Path example)
+--   >>= print . pp
 
 sample :: IO ()
 sample
@@ -89,7 +89,7 @@ sample' example
   >>= print . pp . fst
 
 recognise :: RawTree -> ParserM (LIGO Info)
-recognise = descent (\_ -> error . show . pp) $ map usingScope
+recognise = descent (error "Reasonligo.recognise") $ map usingScope
   [ -- Contract
     Descent do
       boilerplate $ \case

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

@@ -43,10 +43,10 @@ import ParseTree
 --   >>= runParserM . recognise
 --   >>= return . fst
 
-source' :: FilePath -> IO ()
-source' f
-  =   toParseTree (Path f)
-  >>= print . pp
+-- source' :: FilePath -> IO ()
+-- source' f
+--   =   toParseTree (Path f)
+--   >>= print . pp
 
 -- sample :: IO ()
 -- sample
@@ -60,7 +60,7 @@ source' f
 --   >>= print . pp
 
 recognise :: RawTree -> ParserM (LIGO Info)
-recognise = descent (\_ -> error . show . pp) $ map usingScope
+recognise = descent (error "Reasonligo.recognise") $ map usingScope
   [ -- Contract
     Descent do
       boilerplate \case

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

@@ -44,7 +44,7 @@ import           Product
 --   >>= print . pp . fst
 
 recognise :: RawTree -> ParserM (LIGO Info)
-recognise = descent (\_ -> error . show . pp) $ map usingScope
+recognise = descent (error "Reasonligo.recognise") $ map usingScope
   [ -- Contract
     Descent do
       boilerplate $ \case

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

@@ -17,7 +17,9 @@ import           Control.Arrow (second)
 import           Control.Monad.State
 import           Control.Monad.Catch
 import           Control.Monad.Catch.Pure
+import           Control.Monad.Writer (WriterT, execWriterT, tell)
 
+import           Data.Monoid (First(getFirst))
 import qualified Data.List   as List
 import           Data.Map            (Map)
 import qualified Data.Map    as Map
@@ -46,7 +48,7 @@ data Category = Variable | Type
 
 -- | The type/value declaration.
 data ScopedDecl = ScopedDecl
-  { _sdName    :: LIGO ()
+  { _sdName    :: Text
   , _sdOrigin  :: Range
   , _sdBody    :: Maybe Range
   , _sdType    :: Maybe (Either (LIGO ()) Kind)
@@ -98,12 +100,6 @@ ofCategory _        _                                          = False
 
 type Info' = Product [[ScopedDecl], Maybe Category, [Text], Range, ShowRange]
 
--- instance Modifies (Product '[[ScopedDecl], Maybe Category, [Text], Range, a]) where
---   ascribe (ds :> _ :> _ :> r :> _) d =
---     color 3 (fsep (map (pp . _sdName) ds))
---     $$ pp r
---     $$ d
-
 addLocalScopes
   :: forall xs
   .  (Collectable xs, Eq (Product xs))
@@ -290,16 +286,18 @@ lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl
 lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName)
 
 -- | Add a type declaration to the current scope.
-defType :: HasRange a => LIGO a -> Kind -> LIGO a -> [Text] -> CollectM ()
-defType name kind body doc = do
+defType :: Collectable xs => LIGO (Product xs) -> Kind -> LIGO (Product xs) -> [Text] -> CollectM ()
+defType name' kind body doc = do
   define Type
     $ ScopedDecl
-      (void name)
-      (getRange $ extract name)
+      name
+      r
       (Just $ getRange $ extract body)
       (Just (Right kind))
       []
       doc
+  where
+    (r, name) = getTypeName name'
 
 -- -- observe :: Pretty i => Pretty res => Text -> i -> res -> res
 -- -- observe msg i res
@@ -309,23 +307,79 @@ defType name kind body doc = do
 
 -- | Add a value declaration to the current scope.
 def
-  :: HasRange a
-  => LIGO a
-  -> Maybe (LIGO a)
-  -> Maybe (LIGO a)
+  :: Collectable xs
+  => LIGO (Product xs)
+  -> Maybe (LIGO (Product xs))
+  -> Maybe (LIGO (Product xs))
   -> [Text]
   -> CollectM ()
-def name ty body doc = do
+def name' ty body doc = do
   define Variable
     $ ScopedDecl
-      (void name)
-      (getRange $ extract name)
+      name
+      r
       ((getRange . extract) <$> body)
       ((Left . void) <$> ty)
       []
       doc
+  where
+    (r, name) = getName name'
 
-type Collectable xs = (Contains Range xs, Contains [Text] xs)
+select
+  :: ( Lattice  (Product info)
+     , Contains  ShowRange info
+     , Contains  Range info
+     , Modifies (Product info)
+     , Eq (Product info)
+     )
+  => Text
+  -> [Visit RawLigoList (Product info) (WriterT [LIGO (Product info)] Catch)]
+  -> LIGO (Product info)
+  -> (Range, Text)
+select what handlers t
+  = maybe
+      (error . show $ "Tree does not contain a" <+> pp what <.> ":" <+> pp t <+> pp (getRange $ extract t))
+      (\t -> (getElem $ extract t, ppToText t))
+  $ either (const Nothing) listToMaybe
+  $ runCatch
+  $ execWriterT
+  $ visit handlers
+    t
+
+getName
+  :: ( Lattice  (Product info)
+     , Contains  ShowRange info
+     , Contains  Range info
+     , Modifies (Product info)
+     , Eq (Product info)
+     )
+  => LIGO (Product info)
+  -> (Range, Text)
+getName = select "name"
+  [ Visit \(r, Name t) -> do
+      tell [make (r, Name t)]
+  ]
+
+getTypeName
+  :: ( Lattice  (Product info)
+     , Contains  ShowRange info
+     , Contains  Range info
+     , Modifies (Product info)
+     , Eq (Product info)
+     )
+  => LIGO (Product info)
+  -> (Range, Text)
+getTypeName = select "type name"
+  [ Visit \(r, TypeName t) -> do
+      tell [make (r, TypeName t)]
+  ]
+
+type Collectable xs =
+  ( Contains Range xs
+  , Contains [Text] xs
+  , Contains ShowRange xs
+  , Eq (Product xs)
+  )
 
 instance Collectable xs => Scoped (Product xs) CollectM (LIGO (Product xs)) Contract where
   before r _ = enter r

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

@@ -383,11 +383,11 @@ instance Pretty1 Pattern where
 
 instance Pretty1 Name where
   pp1 = \case
-    Name         raw -> color 2 $ pp raw
+    Name         raw -> pp raw
 
 instance Pretty1 TypeName where
   pp1 = \case
-    TypeName     raw -> color 3 $ pp raw
+    TypeName     raw -> pp raw
 
 instance Pretty1 FieldName where
   pp1 = \case

tools/lsp/squirrel/src/ParseTree.hs

@@ -66,8 +66,8 @@ srcToBytestring = \case
 type RawTree = Tree '[ParseTree] RawInfo
 type RawInfo = Product [Range, Text]
 
-instance {-# OVERLAPS #-} Modifies RawInfo where
-  ascribe (r :> n :> _) d = color 3 (pp n) <+> pp r `indent` pp d
+-- instance {-# OVERLAPS #-} Modifies RawInfo where
+--   ascribe (r :> n :> _) d = color 3 (pp n) <+> pp r `indent` pp d
 
 data TreeKind
   = Error

tools/lsp/squirrel/src/Product.hs

@@ -55,9 +55,6 @@ instance Eq (Product '[]) where
 instance (Eq x, Eq (Product xs)) => Eq (Product (x : xs)) where
   x :> xs == y :> ys = and [x == y, xs == ys]
 
--- instance Modifies (Product xs) where
---   ascribe _ = id
-
 class PrettyProd xs where
   ppProd :: Product xs -> Doc