Remove most warnings and renudant line in AST.Parser
This commit is contained in:
parent
107018e6f3
commit
38c32f01d4
@ -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 ()
|
||||
|
@ -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
|
||||
|
@ -17,7 +17,7 @@ import AST.Scope
|
||||
import Product
|
||||
import Range
|
||||
|
||||
import Debug.Trace
|
||||
-- import Debug.Trace
|
||||
|
||||
type CanSearch xs =
|
||||
( Contains [ScopedDecl] xs
|
||||
|
@ -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
|
||||
]
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user