Remove most warnings and renudant line in AST.Parser

This commit is contained in:
Kirill Andreev 2020-08-05 20:45:22 +04:00
parent 107018e6f3
commit 38c32f01d4
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
6 changed files with 40 additions and 47 deletions

View File

@ -222,16 +222,16 @@ loadFromVFS funs uri = do
(tree, _) <- runParserM . recognise =<< toParseTree (Text fin txt)
return $ addLocalScopes tree
loadByURI
:: J.Uri
-> IO (LIGO Info')
loadByURI uri = do
case J.uriToFilePath uri of
Just fin -> do
(tree, _) <- runParserM . recognise =<< toParseTree (Path fin)
return $ addLocalScopes tree
Nothing -> do
error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed."
-- loadByURI
-- :: J.Uri
-- -> IO (LIGO Info')
-- loadByURI uri = do
-- case J.uriToFilePath uri of
-- Just fin -> do
-- (tree, _) <- runParserM . recognise =<< toParseTree (Path fin)
-- return $ addLocalScopes tree
-- Nothing -> do
-- error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed."
collectErrors
:: Core.LspFuncs ()

View File

@ -12,11 +12,11 @@ import Duplo.Pretty
import AST.Types
import AST.Scope
import AST.Parser
-- import AST.Parser
import Range
import Product
import Debug.Trace
-- import Debug.Trace
complete
@ -32,13 +32,13 @@ complete
complete r tree = do
let l = spineTo (leq r . getElem) tree
word <- listToMaybe l
let scope = getElem (extract word)
let cat = getElem (extract word)
let scope = getElem (extract word)
let nameCat = getElem (extract word)
return
$ filter (isSubseqOf (ppToText word))
$ nub
$ map (ppToText . _sdName)
$ filter (fits cat . catFromType)
$ filter (fits nameCat . catFromType)
$ scope
isSubseqOf :: Text -> Text -> Bool

View File

@ -17,7 +17,7 @@ import AST.Scope
import Product
import Range
import Debug.Trace
-- import Debug.Trace
type CanSearch xs =
( Contains [ScopedDecl] xs

View File

@ -6,12 +6,7 @@ module AST.Parser
-- (example, contract, sample)
where
import Control.Arrow
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Sum (Element)
import AST.Types
@ -19,13 +14,13 @@ import Duplo.Error
import Duplo.Tree
import Duplo.Pretty
import Range
import Product
import Parser
import ParseTree
import Debug.Trace
-- import Debug.Trace
example :: FilePath
-- example = "../../../src/test/contracts/arithmetic.ligo"
-- example = "../../../src/test/contracts/address.ligo"
-- example = "../../../src/test/contracts/annotation.ligo"
@ -115,7 +110,6 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
"map_patch" -> MapPatch <$> field "container" <*> fields "binding"
"set_patch" -> SetPatch <$> field "container" <*> fields "key"
"set_remove" -> SetRemove <$> field "key" <*> field "container"
"map_remove" -> SetRemove <$> field "key" <*> field "container"
"update_record" -> RecordUpd <$> field "record" <*> fields "assignment"
_ -> fallthrough
@ -272,14 +266,14 @@ recognise = descent (\_ -> error . show . pp) $ map usingScope
-- Err
, Descent do
\(r :> _, ParseTree _ _ text) -> do
\(r :> _, ParseTree _ _ text') -> do
withComments do
return (r :> N :> Nil, Err text)
return (r :> N :> Nil, Err text')
, Descent do
\case
(r :> _, ParseTree "ERROR" _ text) -> do
return ([] :> r :> Y :> Nil, Err text)
(r :> _, ParseTree "ERROR" _ text') -> do
return ([] :> r :> Y :> Nil, Err text')
_ -> fallthrough
]

View File

@ -13,9 +13,8 @@ module AST.Scope
-- )
where
import Control.Arrow (first, second)
import Control.Arrow (second)
import Control.Monad.State
import Control.Monad.Identity
import Control.Monad.Catch
import Control.Monad.Catch.Pure
@ -23,23 +22,20 @@ import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (listToMaybe)
import Data.Sum (Element, Apply, Sum)
import Data.Text (Text)
import Data.Either (fromRight)
import Duplo.Lattice
import Duplo.Pretty
import Duplo.Tree
import Duplo.Error
import AST.Parser
-- import AST.Parser
import AST.Types
-- import Comment
import Parser
import Product
import Range
import Debug.Trace
-- import Debug.Trace
type CollectM = StateT (Product [FullEnv, [Range]]) Catch
@ -141,6 +137,7 @@ unLetRec = descent leaveBe
linearize :: Range -> LIGO (Product xs) -> [LIGO (Product xs)] -> LIGO (Product xs)
linearize r b [x] = make (modElem @Range (delta r) $ extract x, Let x b)
linearize r b (x : xs) = make (modElem @Range (delta r) $ extract x, Let x (linearize r b xs))
linearize _ _ [] = error "empty Seq"
delta (Range _ f _) (Range s _ t) = Range s f t

View File

@ -4,7 +4,6 @@ module Parser where
import Control.Arrow
import Control.Monad.Catch
import Control.Monad.RWS hiding (Product)
import Control.Monad.Trans.Maybe
import Data.String.Interpolate (i)
import Data.Text (Text)
@ -18,7 +17,7 @@ import ParseTree
import Range
import Product
import Debug.Trace
-- import Dsebug.Trace
{-
Comment grabber has 2 buffers: 1 and 2.
@ -40,7 +39,7 @@ data Failure = Failure String
deriving anyclass (Exception)
instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where
before (r :> _ :> _) (ParseTree ty cs s) = do
before (r :> _ :> _) (ParseTree _ cs _) = do
let (comms, rest) = allComments cs
let (comms1, _) = allComments $ reverse rest
modify $ first (++ comms)
@ -50,12 +49,12 @@ instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where
tell $ fmap (\t -> (r, Err t)) errs
after _ _ = do
modify \(x, y) -> (y, [])
modify \(_, y) -> (y, [])
grabComments :: ParserM [Text]
grabComments = do
ls <- gets fst
modify \(x, y) -> ([], y)
modify \(_, y) -> ([], y)
return ls
allComments :: [RawTree] -> ([Text], [RawTree])
@ -73,9 +72,10 @@ allErrors = map getBody . filter isUnnamedError
where
isUnnamedError :: RawTree -> Bool
isUnnamedError tree = case only tree of
(r :> "" :> _, ParseTree "ERROR" _ _) -> True
(_ :> "" :> _, ParseTree "ERROR" _ _) -> True
_ -> False
getBody :: RawTree -> Text
getBody (gist -> f) = ptSource f
field :: Text -> ParserM RawTree
@ -90,7 +90,7 @@ fieldOpt name = ask >>= go
| n == name = return (Just tree)
| otherwise = go rest
go [] = return Nothing
go _ = return Nothing
fields :: Text -> ParserM [RawTree]
fields name = ask >>= go
@ -98,7 +98,7 @@ fields name = ask >>= go
go (tree@(extract -> _ :> n :> _) : rest) =
(if n == name then ((tree :) <$>) else id)
$ go rest
go [] = return []
go _ = return []
data ShowRange
= Y | N
@ -122,11 +122,13 @@ instance
= ascribeRange (getElem @Range xs) (getElem xs)
. ascribeComms (getElem xs)
ascribeComms :: [Text] -> Doc -> Doc
ascribeComms comms
| null comms = id
| otherwise = \d ->
block $ map (pp . Text.init) comms ++ [d]
ascribeRange :: Pretty p => p -> ShowRange -> Doc -> Doc
ascribeRange r Y = (pp r $$)
ascribeRange _ _ = id
@ -142,8 +144,8 @@ boilerplate
-> ParserM (Info, f RawTree)
boilerplate f (r :> _, ParseTree ty cs _) = do
withComments do
f <- local (const cs) $ f ty
return $ (r :> N :> Nil, f)
f' <- local (const cs) $ f ty
return $ (r :> N :> Nil, f')
boilerplate'
:: ((Text, Text) -> ParserM (f RawTree))
@ -151,8 +153,8 @@ boilerplate'
-> ParserM (Info, f RawTree)
boilerplate' f (r :> _, ParseTree ty cs src) = do
withComments do
f <- local (const cs) $ f (ty, src)
return $ (r :> N :> Nil, f)
f' <- local (const cs) $ f (ty, src)
return $ (r :> N :> Nil, f')
fallthrough :: MonadThrow m => m a
fallthrough = throwM HandlerFailed