diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,40 @@ # Revision history for hpython +## 0.3 + +* Changed the sigature of `Data.Validation.Monadic.bindVM` to have the same form as + `(>>=)` + +* Added `HasAnn` instance for `Language.Python.Syntax.Ann.Ann` + +* Reworked scope checking (`Language.Python.Validate.Scope`) + + Instead of the old triplicate `ScopeContext`, we now keep a single context + and mark each entry with its 'occurrence path'. This is much simpler to manage, + but just as expressive as the old version. + +* Improved scope checking of compound statements + + Compound statements like + + ``` + if ...: + x = 1 + else: + y = x + ``` + + were succeeding in scope checking because the variables from each block were + added to the scope sequentially. Now, the multiple blocks are checked in the + same scope, and their final scopes are combined at the end of the process. + +* Added `Foldable1`/`Traversable1` instances for `CommaSep1` and `CommaSep1'` + +* Added `HasStatements1` with instances for `Statement` and `Block` + ## 0.2 + +*2019-01-10* * Improved Plated instance for exprs diff --git a/hpython.cabal b/hpython.cabal --- a/hpython.cabal +++ b/hpython.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hpython -version: 0.2 +version: 0.3 synopsis: Python language tools description: `hpython` provides an abstract syntax tree for Python 3.5, along with a parser, @@ -64,7 +64,7 @@ tested-with: GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.4 - , GHC == 8.6.1 + , GHC == 8.6.4 source-repository head @@ -136,7 +136,7 @@ , deriving-compat >=0.4 && <0.6 , semigroupoids >=5.2.2 && <5.4 , text >=1.2 && <1.3 - , these >=0.7.4 && <0.8 + , these >=0.7.4 && <0.9 , validation >= 1 && < 1.1 , parsers-megaparsec >=0.1 && <0.2 hs-source-dirs: src diff --git a/src/Data/Validate/Monadic.hs b/src/Data/Validate/Monadic.hs --- a/src/Data/Validate/Monadic.hs +++ b/src/Data/Validate/Monadic.hs @@ -38,9 +38,14 @@ runValidateM :: ValidateM e m a -> m (Validation e a) runValidateM = getCompose . unValidateM --- | Bind into a 'ValidateM'. Note that the first parameter is @m a@, not @ValidateM e m a@. -bindVM :: Monad m => m a -> (a -> ValidateM e m b) -> ValidateM e m b -bindVM m f = ValidateM . Compose $ m >>= getCompose . unValidateM . f +-- | Bind into a 'ValidateM' +bindVM :: Monad m => ValidateM e m a -> (a -> ValidateM e m b) -> ValidateM e m b +bindVM m f = + ValidateM . Compose $ do + res <- getCompose $ unValidateM m + case res of + Failure err -> pure $ Failure err + Success a -> getCompose . unValidateM $ f a -- | Lift into a succeeding validation liftVM0 :: (Functor m, Semigroup e) => m a -> ValidateM e m a diff --git a/src/Language/Python/Syntax/Ann.hs b/src/Language/Python/Syntax/Ann.hs --- a/src/Language/Python/Syntax/Ann.hs +++ b/src/Language/Python/Syntax/Ann.hs @@ -34,6 +34,9 @@ class HasAnn s where annot :: Lens' (s a) (Ann a) +instance HasAnn Ann where + annot = id + -- | Get an annotation and forget the wrapper annot_ :: HasAnn s => Lens' (s a) a annot_ = annot._Wrapped diff --git a/src/Language/Python/Syntax/CommaSep.hs b/src/Language/Python/Syntax/CommaSep.hs --- a/src/Language/Python/Syntax/CommaSep.hs +++ b/src/Language/Python/Syntax/CommaSep.hs @@ -29,9 +29,12 @@ import Data.Coerce (coerce) import Data.Function ((&)) import Data.Functor (($>)) +import Data.Functor.Apply ((<.>)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe) import Data.Semigroup (Semigroup(..)) +import Data.Semigroup.Foldable (Foldable1(..)) +import Data.Semigroup.Traversable (Traversable1(..), foldMap1Default) import GHC.Generics (Generic) import Language.Python.Syntax.Punctuation @@ -94,6 +97,13 @@ | CommaSepMany1 a Comma (CommaSep1 a) deriving (Eq, Show, Functor, Foldable, Traversable, Generic) +instance Foldable1 CommaSep1 where; foldMap1 = foldMap1Default +instance Traversable1 CommaSep1 where + traverse1 f = go + where + go (CommaSepOne1 a) = CommaSepOne1 <$> f a + go (CommaSepMany1 a b c) = (\a' c' -> CommaSepMany1 a' b c') <$> f a <.> go c + -- | Get the first element of a 'CommaSep1' commaSep1Head :: CommaSep1 a -> a commaSep1Head (CommaSepOne1 a) = a @@ -141,6 +151,13 @@ = CommaSepOne1' a (Maybe Comma) | CommaSepMany1' a Comma (CommaSep1' a) deriving (Eq, Show, Functor, Foldable, Traversable, Generic) + +instance Foldable1 CommaSep1' where; foldMap1 = foldMap1Default +instance Traversable1 CommaSep1' where + traverse1 f = go + where + go (CommaSepOne1' a b) = (\a' -> CommaSepOne1' a' b) <$> f a + go (CommaSepMany1' a b c) = (\a' c' -> CommaSepMany1' a' b c') <$> f a <.> go c -- | Iso to unpack a 'CommaSep' _CommaSep diff --git a/src/Language/Python/Syntax/Statement.hs b/src/Language/Python/Syntax/Statement.hs --- a/src/Language/Python/Syntax/Statement.hs +++ b/src/Language/Python/Syntax/Statement.hs @@ -21,6 +21,7 @@ Statement(..) -- ** Traversals , HasStatements(..) + , HasStatements1(..) -- * Decorators , Decorator(..) -- ** Compound statements @@ -62,14 +63,15 @@ import Control.Lens.Prism (_Right) import Control.Lens.Setter ((.~), over, mapped) import Control.Lens.TH (makeLenses) -import Control.Lens.Traversal (Traversal, traverseOf) +import Control.Lens.Traversal (Traversal, Traversal1, traverseOf) import Control.Lens.Tuple (_1, _2, _3, _4) import Data.Bifoldable (bifoldMap) import Data.Bifunctor (bimap) import Data.Bitraversable (bitraverse) import Data.Coerce (coerce) +import Data.Functor.Apply ((<.>)) import Data.Generics.Product.Typed (typed) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (isNothing) import Data.Monoid ((<>)) import GHC.Generics (Generic) @@ -104,6 +106,9 @@ class HasStatements s where _Statements :: Traversal (s v a) (s '[] a) (Statement v a) (Statement '[] a) +class HasStatements s => HasStatements1 s where + _Statements1 :: Traversal1 (s v a) (s '[] a) (Statement v a) (Statement '[] a) + -- | A 'Block' is an indented multi-line chunk of code, forming part of a -- 'Suite'. data Block (v :: [*]) a @@ -186,6 +191,20 @@ _Statements f (Block a b c) = Block a <$> f b <*> (traverse._Right) f c +instance HasStatements1 Block where + _Statements1 f (Block a l m) = uncurry (Block a) <$> go l m + where + go b [] = (\b' -> (b', [])) <$> f b + go b (Left c:cs) = + (\(b', cs') -> (b', Left c:cs')) <$> + go b cs + go b (Right c:cs) = + (,) <$> + f b <.> + fmap + (\(c', cs') -> Right c' : cs') + (go c cs) + instance HasStatements Suite where _Statements _ (SuiteOne a b c) = pure $ SuiteOne a b (c ^. unvalidated) _Statements f (SuiteMany a b c d e) = SuiteMany a b c d <$> _Statements f e @@ -211,6 +230,9 @@ instance HasStatements Statement where _Statements = id + +instance HasStatements1 Statement where + _Statements1 = id instance HasExprs SmallStatement where _Exprs f (MkSmallStatement s ss a b c) = diff --git a/src/Language/Python/Validate/Scope.hs b/src/Language/Python/Validate/Scope.hs --- a/src/Language/Python/Validate/Scope.hs +++ b/src/Language/Python/Validate/Scope.hs @@ -1,10 +1,11 @@ {-# language DataKinds, TypeOperators #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language TemplateHaskell, TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-} +{-# language DeriveFunctor #-} {-# language FlexibleContexts #-} {-# language RankNTypes #-} {-# language LambdaCase #-} +{-# language OverloadedLists #-} {-# language ScopedTypeVariables, TypeApplications #-} +{-# language MultiParamTypeClasses #-} {-| Module : Language.Python.Validate.Scope @@ -25,15 +26,15 @@ , validateExprScope -- * Miscellany -- ** Extra types - , ScopeContext(..), scGlobalScope, scLocalScope, scImmediateScope - , runValidateScope' - , initialScopeContext - , Binding(..) + , Level(..), Entry(..) -- ** Extra functions + , runValidateScope' + , definitionScope + , controlScope , inScope + , lookupScope + , localScope , extendScope - , locallyOver - , locallyExtendOver -- ** Validation functions , validateArgScope , validateAssignExprScope @@ -56,34 +57,34 @@ import Data.Validation -import Control.Arrow ((&&&)) -import Control.Applicative ((<|>)) import Control.Lens.Cons (snoc) import Control.Lens.Fold ((^..), toListOf, folded) -import Control.Lens.Getter ((^.), view, to, getting, use) -import Control.Lens.Lens (Lens') +import Control.Lens.Getter ((^.), to, getting) import Control.Lens.Plated (cosmos) import Control.Lens.Prism (_Right, _Just) import Control.Lens.Review ((#)) -import Control.Lens.Setter ((%~), (.~), Setter', mapped, over) -import Control.Lens.TH (makeLenses) +import Control.Lens.Setter (mapped, over) import Control.Lens.Tuple (_2, _3) import Control.Lens.Traversal (traverseOf) -import Control.Monad.State (MonadState, State, evalState, modify) +import Control.Monad.State (State, evalState, modify, get, put) +import Control.Monad.Reader (ReaderT, runReaderT, ask, local) import Data.Bitraversable (bitraverse) import Data.ByteString (ByteString) import Data.Coerce (coerce) -import Data.Foldable (traverse_) -import Data.Functor.Compose (Compose(..)) +import Data.Foldable (toList, traverse_) import Data.List.NonEmpty (NonEmpty(..)) import Data.Map.Strict (Map) +import Data.Maybe (isJust) +import Data.Sequence ((|>), Seq) import Data.String (fromString) import Data.Type.Set (Nub) -import Data.Validate.Monadic (ValidateM(..), runValidateM, bindVM, liftVM0, errorVM1) +import Data.Validate.Monadic + (ValidateM(..), runValidateM, bindVM, liftVM0, liftVM1, errorVM1) import Unsafe.Coerce (unsafeCoerce) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map +import Data.Sequence as Seq import Language.Python.Optics import Language.Python.Optics.Validated (unvalidated) @@ -96,87 +97,67 @@ data Scope -data Binding = Clean | Dirty - deriving (Eq, Ord, Show) - -data ScopeContext a - = ScopeContext - { _scGlobalScope :: !(Map ByteString a) - , _scLocalScope :: !(Map ByteString a) - , _scImmediateScope :: !(Map ByteString a) - } +data Level + = Toplevel + | Definition + | Control deriving (Eq, Show) -makeLenses ''ScopeContext -initialScopeContext :: ScopeContext a -initialScopeContext = ScopeContext Map.empty Map.empty Map.empty +data Entry a + = Entry + { _entryValue :: a + , _entryPath :: !(Seq Level) + } deriving (Eq, Show, Functor) -type ValidateScope ann e = ValidateM (NonEmpty e) (State (ScopeContext ann)) +type ValidateScope ann e + = ValidateM + (NonEmpty e) + (ReaderT (Seq Level) (State (Map ByteString (Entry ann)))) runValidateScope :: ValidateScope ann e a -> Validation (NonEmpty e) a -runValidateScope = runValidateScope' initialScopeContext +runValidateScope = runValidateScope' [Toplevel] mempty -runValidateScope' :: ScopeContext ann -> ValidateScope ann e a -> Validation (NonEmpty e) a -runValidateScope' s = flip evalState s . runValidateM +runValidateScope' :: + Seq Level {- ^ Path -} -> + Map ByteString (Entry ann) {- ^ Context -} -> + ValidateScope ann e a {- ^ Validation action -} -> + Validation (NonEmpty e) a +runValidateScope' path s = flip evalState s . flip runReaderT path . runValidateM -extendScope - :: Setter' (ScopeContext ann) (Map ByteString ann) - -> [(ann, String)] - -> ValidateScope ann e () -extendScope l s = - liftVM0 $ do - gs <- use scGlobalScope - let t = buildMap gs Map.empty - modify (over l (t `unionL`)) - where - buildMap gs t = - foldr - (\(ann, a) b -> - let - a' = fromString a - in - if Map.member a' gs - then b - else Map.insert a' ann b) - t - s +localScope :: + (Map ByteString (Entry ann) -> Map ByteString (Entry ann)) -> + ValidateScope ann e a -> + ValidateScope ann e a +localScope f m = + liftVM0 get `bindVM` \s -> + liftVM0 (modify f) *> + m <* liftVM0 (put s) -locallyOver - :: Lens' (ScopeContext ann) b - -> (b -> b) - -> ValidateScope ann e a - -> ValidateScope ann e a -locallyOver l f m = - ValidateM . Compose $ do - before <- use l - modify (l %~ f) - getCompose (unValidateM m) <* modify (l .~ before) +-- | Run a validation action for a definition block +definitionScope :: ValidateScope ann e a -> ValidateScope ann e a +definitionScope = liftVM1 (local (|> Definition)) . localScope id -locallyExtendOver - :: Lens' (ScopeContext ann) (Map ByteString ann) - -> [(ann, String)] - -> ValidateScope ann e a - -> ValidateScope ann e a -locallyExtendOver l s m = locallyOver l id $ extendScope l s *> m +-- | Run a validation action for a flow control block +controlScope :: ValidateScope ann e a -> ValidateScope ann e a +controlScope = liftVM1 (local (|> Control)) -inScope - :: MonadState (ScopeContext ann) m - => String - -> m (Maybe (Binding, ann)) -inScope s = do - gs <- use scGlobalScope - ls <- use scLocalScope - is <- use scImmediateScope - let - s' = fromString s - inls = Map.lookup s' ls - ings = Map.lookup s' gs - pure $ - ((,) Clean <$> Map.lookup s' is) <|> - (ings *> ((,) Clean <$> inls)) <|> - ((,) Clean <$> ings) <|> - ((,) Dirty <$> inls) +-- | Add some entries to the context, using the current depth and level +extendScope :: [Ident v ann] -> ValidateScope ann e () +extendScope entries = + liftVM0 ask `bindVM` \path -> + liftVM0 . modify $ \scope -> + foldr + (\ident -> + Map.insert (fromString $ _identValue ident) (Entry (ident ^. annot_) path)) + scope + entries +inScope :: String -> ValidateScope ann e Bool +inScope = fmap isJust . lookupScope + +lookupScope :: String -> ValidateScope ann e (Maybe (Entry ann)) +lookupScope s = Map.lookup (fromString s) <$> liftVM0 get + validateExceptAsScope :: AsScopeError e a => ExceptAs v a @@ -202,122 +183,147 @@ (\d' -> Decorator a b c d' e f g) <$> validateExprScope d +parallel2 :: + ValidateScope a e x -> + ValidateScope a e y -> + ValidateScope a e (x, y) +parallel2 a b = + liftVM0 get `bindVM` \st -> + ((,) <$> + ((,) <$ liftVM0 (put st) <*> a <*> liftVM0 get) <*> + ((,) <$ liftVM0 (put st) <*> b <*> liftVM0 get)) `bindVM` + \((ares, ast), (bres, bst)) -> + (ares, bres) <$ + liftVM0 + (put $ + Map.unionWith + (\e1 e2 -> + if Seq.length (_entryPath e1) < Seq.length (_entryPath e2) + then e2 + else e1) + ast + bst) + +parallelList :: + (x -> ValidateScope a e y) -> + [x] -> + ValidateScope a e [y] +parallelList _ [] = pure [] +parallelList f (x:xs) = uncurry (:) <$> parallel2 (f x) (parallelList f xs) + +parallelNonEmpty :: + (x -> ValidateScope a e y) -> + NonEmpty x -> + ValidateScope a e (NonEmpty y) +parallelNonEmpty f (x:|xs) = uncurry (:|) <$> parallel2 (f x) (parallelList f xs) + +parallel3 :: + ValidateScope a e x1 -> + ValidateScope a e x2 -> + ValidateScope a e x3 -> + ValidateScope a e (x1, x2, x3) +parallel3 a b c = (\(a', (b', c')) -> (a', b', c')) <$> parallel2 a (parallel2 b c) + +parallel4 :: + ValidateScope a e x1 -> + ValidateScope a e x2 -> + ValidateScope a e x3 -> + ValidateScope a e x4 -> + ValidateScope a e (x1, x2, x3, x4) +parallel4 a b c d = + (\(a', (b', c', d')) -> (a', b', c', d')) <$> parallel2 a (parallel3 b c d) + validateCompoundStatementScope :: forall e v a . AsScopeError e a => CompoundStatement v a -> ValidateScope a e (CompoundStatement (Nub (Scope ': v)) a) validateCompoundStatementScope (Fundef a decos idnts asyncWs ws1 name ws2 params ws3 mty s) = - (locallyOver scLocalScope (const Map.empty) $ - locallyOver scImmediateScope (const Map.empty) $ - (\decos' -> Fundef a decos' idnts asyncWs ws1 (coerce name) ws2) <$> - traverse validateDecoratorScope decos <*> - traverse validateParamScope params <*> - pure ws3 <*> - traverseOf (traverse._2) validateExprScope mty <*> - locallyExtendOver - scGlobalScope - ((view annot_ &&& _identValue) name : - toListOf (folded.getting paramName.to (view annot_ &&& _identValue)) params) - (validateSuiteScope s)) <* - extendScope scLocalScope [(view annot_ &&& _identValue) name] <* - extendScope scImmediateScope [(view annot_ &&& _identValue) name] + (\decos' -> Fundef a decos' idnts asyncWs ws1 (coerce name) ws2) <$> + traverse validateDecoratorScope decos <*> + traverse validateParamScope params <*> + pure ws3 <*> + traverseOf (traverse._2) validateExprScope mty <*> + definitionScope + (extendScope (name : toListOf (folded.getting paramName) params) *> + validateSuiteScope s) <* + extendScope [name] validateCompoundStatementScope (If idnts a ws1 e b elifs melse) = - use scLocalScope `bindVM` (\ls -> - use scImmediateScope `bindVM` (\is -> - locallyOver scGlobalScope (`unionR` unionR ls is) $ - locallyOver scImmediateScope (const Map.empty) - (If idnts a ws1 <$> - validateExprScope e <*> - validateSuiteScope b <*> - traverse - (\(a, b, c, d) -> - (\c' -> (,,,) a b c') <$> - validateExprScope c <*> - validateSuiteScope d) - elifs <*> - traverseOf (traverse._3) validateSuiteScope melse))) + (\e' (b', elifs', melse') -> If idnts a ws1 e' b' elifs' melse') <$> + validateExprScope e <*> + parallel3 + (controlScope $ validateSuiteScope b) + (parallelList + (\(a, b, c, d) -> + (,,,) a b <$> + validateExprScope c <*> + controlScope (validateSuiteScope d)) + elifs) + (traverseOf (traverse._3) (controlScope . validateSuiteScope) melse) validateCompoundStatementScope (While idnts a ws1 e b els) = - use scLocalScope `bindVM` (\ls -> - use scImmediateScope `bindVM` (\is -> - locallyOver scGlobalScope (`unionR` unionR ls is) $ - locallyOver scImmediateScope (const Map.empty) - (While idnts a ws1 <$> - validateExprScope e <*> - validateSuiteScope b <*> - traverseOf (traverse._3) validateSuiteScope els))) + While idnts a ws1 <$> + validateExprScope e <*> + controlScope (validateSuiteScope b) <*> + traverseOf (traverse._3) (controlScope . validateSuiteScope) els validateCompoundStatementScope (TryExcept idnts a b e f k l) = - use scLocalScope `bindVM` (\ls -> - use scImmediateScope `bindVM` (\is -> - locallyOver scGlobalScope (`unionR` unionR ls is) $ - locallyOver scImmediateScope (const Map.empty) - (TryExcept idnts a b <$> - validateSuiteScope e <*> - traverse + (\(e', f', k', l') -> TryExcept idnts a b e' f' k' l') <$> + parallel4 + (controlScope $ validateSuiteScope e) + (parallelNonEmpty (\(idnts, ws, g, h) -> - (,,,) idnts ws <$> - traverse validateExceptAsScope g <*> - locallyExtendOver - scGlobalScope - (toListOf (folded.exceptAsName._Just._2.to (view annot_ &&& _identValue)) g) - (validateSuiteScope h)) - f <*> - traverseOf (traverse._3) validateSuiteScope k <*> - traverseOf (traverse._3) validateSuiteScope l))) + (,,,) idnts ws <$> + traverse validateExceptAsScope g <*> + controlScope + (extendScope (toListOf (folded.exceptAsName._Just._2) g) *> + validateSuiteScope h)) + f) + (traverseOf (traverse._3) (controlScope . validateSuiteScope) k) + (traverseOf (traverse._3) (controlScope . validateSuiteScope) l) validateCompoundStatementScope (TryFinally idnts a b e idnts2 f i) = - use scLocalScope `bindVM` (\ls -> - use scImmediateScope `bindVM` (\is -> - locallyOver scGlobalScope (`unionR` unionR ls is) $ - locallyOver scImmediateScope (const Map.empty) - (TryFinally idnts a b <$> - validateSuiteScope e <*> - pure idnts2 <*> - pure f <*> - validateSuiteScope i))) + (\(e', i') -> TryFinally idnts a b e' idnts2 f i') <$> + parallel2 + (controlScope $ validateSuiteScope e) + (controlScope $ validateSuiteScope i) validateCompoundStatementScope (For idnts a asyncWs b c d e h i) = - use scLocalScope `bindVM` (\ls -> - use scImmediateScope `bindVM` (\is -> - locallyOver scGlobalScope (`unionR` unionR ls is) $ - locallyOver scImmediateScope (const Map.empty) $ - For @(Nub (Scope ': v)) idnts a asyncWs b <$> + let + cs = c ^.. unvalidated.cosmos._Ident + in + (\c' d' e' (h', i') -> For idnts a asyncWs b c' d' e' h' i') <$> (unsafeCoerce c <$ traverse (\s -> - inScope (s ^. identValue) `bindVM` \res -> - maybe (pure ()) (\_ -> errorVM1 (_BadShadowing # coerce s)) res) - (c ^.. unvalidated.cosmos._Ident)) <*> + inScope (s ^. identValue) `bindVM` \res -> + if res then errorVM1 (_BadShadowing # coerce s) else pure ()) + cs) <*> pure d <*> traverse validateExprScope e <*> - (let - ls = c ^.. unvalidated.cosmos._Ident.to (view annot_ &&& _identValue) - in - extendScope scLocalScope ls *> - extendScope scImmediateScope ls *> - validateSuiteScope h) <*> - traverseOf (traverse._3) validateSuiteScope i)) + parallel2 + (controlScope $ + extendScope (toList cs) *> + validateSuiteScope h) + (traverseOf (traverse._3) (controlScope . validateSuiteScope) i) validateCompoundStatementScope (ClassDef a decos idnts b c d g) = - (\decos' -> ClassDef @(Nub (Scope ': v)) a decos' idnts b (coerce c)) <$> + (\decos' -> ClassDef a decos' idnts b (coerce c)) <$> traverse validateDecoratorScope decos <*> traverseOf (traverse._2.traverse.traverse) validateArgScope d <*> - validateSuiteScope g <* - extendScope scImmediateScope [c ^. to (view annot_ &&& _identValue)] + definitionScope (validateSuiteScope g) <* + extendScope [c] validateCompoundStatementScope (With a b asyncWs c d e) = let names = d ^.. folded.unvalidated.to _withItemBinder.folded._2. - assignTargets.to (view annot_ &&& _identValue) + assignTargets in - With @(Nub (Scope ': v)) a b asyncWs c <$> + With a b asyncWs c <$> traverse (\(WithItem a b c) -> WithItem @(Nub (Scope ': v)) a <$> validateExprScope b <*> traverseOf (traverse._2) validateAssignExprScope c) d <* - extendScope scLocalScope names <* - extendScope scImmediateScope names <*> - validateSuiteScope e + extendScope names <*> + controlScope (validateSuiteScope e) validateSimpleStatementScope :: AsScopeError e a @@ -338,18 +344,11 @@ validateSimpleStatementScope (Return a ws e) = Return a ws <$> traverse validateExprScope e validateSimpleStatementScope (Expr a e) = Expr a <$> validateExprScope e validateSimpleStatementScope (Assign a l rs) = - let - ls = - (l : (snd <$> NonEmpty.init rs)) ^.. - folded.unvalidated.assignTargets.to (view annot_ &&& _identValue) - in Assign a <$> validateAssignExprScope l <*> ((\a b -> case a of; [] -> b :| []; a : as -> a :| snoc as b) <$> traverseOf (traverse._2) validateAssignExprScope (NonEmpty.init rs) <*> - (\(ws, b) -> (,) ws <$> validateExprScope b) (NonEmpty.last rs)) <* - extendScope scLocalScope ls <* - extendScope scImmediateScope ls + (\(ws, b) -> (,) ws <$> validateExprScope b) (NonEmpty.last rs)) validateSimpleStatementScope (AugAssign a l aa r) = (\l' -> AugAssign a l' aa) <$> validateExprScope l <*> @@ -391,12 +390,15 @@ => Ident v a -> ValidateScope a e (Ident (Nub (Scope ': v)) a) validateIdentScope i = - inScope (_identValue i) `bindVM` - \context -> - case context of - Just (Clean, _) -> pure $ coerce i - Just (Dirty, ann)-> errorVM1 (_FoundDynamic # (ann, i ^. unvalidated)) - Nothing -> errorVM1 (_NotInScope # (i ^. unvalidated)) + lookupScope (_identValue i) `bindVM` \res -> + liftVM0 ask `bindVM` \curPath -> + case res of + Nothing -> errorVM1 (_NotInScope # (i ^. unvalidated)) + Just (Entry ann path) -> + coerce i <$ + if Seq.length curPath < Seq.length path + then errorVM1 (_FoundDynamic # (ann, i ^. unvalidated)) + else pure () validateArgScope :: AsScopeError e a @@ -446,11 +448,11 @@ -> Comprehension ex v a -> ValidateScope a e (Comprehension ex (Nub (Scope ': v)) a) validateComprehensionScope f (Comprehension a b c d) = - locallyOver scGlobalScope id $ - (\c' d' b' -> Comprehension a b' c' d') <$> - validateCompForScope c <*> - traverse (bitraverse validateCompForScope validateCompIfScope) d <*> - f b + controlScope $ + (\c' d' b' -> Comprehension a b' c' d') <$> + validateCompForScope c <*> + traverse (bitraverse validateCompForScope validateCompIfScope) d <*> + f b where validateCompForScope :: AsScopeError e a @@ -460,8 +462,7 @@ (\c' -> CompFor a b c' d) <$> validateAssignExprScope c <*> validateExprScope e <* - extendScope scGlobalScope - (c ^.. unvalidated.assignTargets.to (view annot_ &&& _identValue)) + extendScope (c ^.. unvalidated.assignTargets) validateCompIfScope :: AsScopeError e a @@ -502,6 +503,16 @@ where tupleItem (TupleItem a b) = TupleItem a <$> validateAssignExprScope b tupleItem (TupleUnpack a b c d) = TupleUnpack a b c <$> validateAssignExprScope d +validateAssignExprScope (Ident a (MkIdent b c d)) = + lookupScope c `bindVM` \res -> + liftVM0 ask `bindVM` \curPath -> + Ident a (MkIdent b c d) <$ + case res of + Nothing -> extendScope [MkIdent b c d] + Just (Entry _ path)-> + if Seq.length curPath < Seq.length path + then extendScope [MkIdent b c d] + else pure () validateAssignExprScope e@Unit{} = pure $ unsafeCoerce e validateAssignExprScope e@Lambda{} = pure $ unsafeCoerce e validateAssignExprScope e@Yield{} = pure $ unsafeCoerce e @@ -511,7 +522,6 @@ validateAssignExprScope e@Call{} = pure $ unsafeCoerce e validateAssignExprScope e@UnOp{} = pure $ unsafeCoerce e validateAssignExprScope e@BinOp{} = pure $ unsafeCoerce e -validateAssignExprScope e@Ident{} = pure $ unsafeCoerce e validateAssignExprScope e@None{} = pure $ unsafeCoerce e validateAssignExprScope e@Ellipsis{} = pure $ unsafeCoerce e validateAssignExprScope e@Int{} = pure $ unsafeCoerce e @@ -668,9 +678,3 @@ ModuleStatement <$> validateStatementScope a <*> validateModuleScope b - -unionL :: Ord k => Map k v -> Map k v -> Map k v -unionL = Map.unionWith const - -unionR :: Ord k => Map k v -> Map k v -> Map k v -unionR = Map.unionWith (const id) diff --git a/src/Language/Python/Validate/Syntax.hs b/src/Language/Python/Validate/Syntax.hs --- a/src/Language/Python/Validate/Syntax.hs +++ b/src/Language/Python/Validate/Syntax.hs @@ -212,7 +212,7 @@ | not (all isAscii name) = errorVM1 (_BadCharacter # (getAnn a, name)) | null name = errorVM1 (_EmptyIdentifier # getAnn a) | otherwise = - bindVM (view inFunction) $ \fi -> + bindVM (liftVM0 $ view inFunction) $ \fi -> let reserved = reservedWords <> @@ -230,7 +230,7 @@ -> f Whitespace -> ValidateSyntax e (f Whitespace) validateWhitespace ann ws = - ask `bindVM` \ctxt -> + liftVM0 ask `bindVM` \ctxt -> if _inParens ctxt then pure ws else if @@ -492,7 +492,7 @@ validateExprSyntax (Yield a b c) = Yield a <$> validateWhitespace (getAnn a) b <* - (ask `bindVM` \ctxt -> + (liftVM0 ask `bindVM` \ctxt -> case _inFunction ctxt of Nothing | _inGenerator ctxt -> pure () @@ -506,7 +506,7 @@ YieldFrom a <$> validateWhitespace (getAnn a) b <*> validateWhitespace (getAnn a) c <* - (ask `bindVM` \ctxt -> + (liftVM0 ask `bindVM` \ctxt -> case _inFunction ctxt of Nothing | _inGenerator ctxt -> pure () @@ -574,7 +574,7 @@ validateExprSyntax (Generator a comp) = Generator a <$> validateComprehensionSyntax validateExprSyntax comp validateExprSyntax (Await a ws expr) = - bindVM ask $ \ctxt -> + bindVM (liftVM0 ask) $ \ctxt -> Await a <$> validateWhitespace (getAnn a) ws <* (if not $ fromMaybe False (ctxt ^? inFunction._Just.asyncFunction) @@ -792,7 +792,7 @@ (local $ (inClass .~ True) . (inFunction .~ Nothing)) (validateSuiteSyntax g) validateCompoundStatementSyntax (For a idnts asyncWs b c d e h i) = - bindVM ask $ \ctxt -> + bindVM (liftVM0 ask) $ \ctxt -> For a idnts <$ (if isJust asyncWs && not (fromMaybe False $ ctxt ^? inFunction._Just.asyncFunction) then errorVM1 (_AsyncForOutsideCoroutine # getAnn a) @@ -812,7 +812,7 @@ validateSuiteSyntax w) i validateCompoundStatementSyntax (With a b asyncWs c d e) = - bindVM ask $ \ctxt -> + bindVM (liftVM0 ask) $ \ctxt -> With a b <$ (if isJust asyncWs && not (fromMaybe False $ ctxt ^? inFunction._Just.asyncFunction) then errorVM1 (_AsyncWithOutsideCoroutine # getAnn a) @@ -872,7 +872,7 @@ => ImportTargets v a -> ValidateSyntax e (ImportTargets (Nub (Syntax ': v)) a) validateImportTargetsSyntax (ImportAll a ws) = - bindVM ask $ \ctxt -> + bindVM (liftVM0 ask) $ \ctxt -> if ctxt ^. inClass || has (inFunction._Just) ctxt then errorVM1 $ _WildcardImportInDefinition # getAnn a else ImportAll a <$> validateWhitespace (getAnn a) ws @@ -943,7 +943,7 @@ c) f validateSimpleStatementSyntax (Return a ws expr) = - ask `bindVM` \sctxt -> + liftVM0 ask `bindVM` \sctxt -> case _inFunction sctxt of Just{} -> Return a <$> @@ -954,7 +954,7 @@ Expr a <$> validateExprSyntax expr validateSimpleStatementSyntax (Assign a lvalue rs) = - ask `bindVM` \sctxt -> + liftVM0 ask `bindVM` \sctxt -> let assigns = if isJust (_inFunction sctxt) @@ -990,14 +990,14 @@ Pass a <$> validateWhitespace (getAnn a) ws validateSimpleStatementSyntax (Break a ws) = Break a <$ - (ask `bindVM` \sctxt -> + (liftVM0 ask `bindVM` \sctxt -> if _inLoop sctxt then pure () else errorVM1 (_BreakOutsideLoop # getAnn a)) <*> validateWhitespace (getAnn a) ws validateSimpleStatementSyntax (Continue a ws) = Continue a <$ - (ask `bindVM` \sctxt -> + (liftVM0 ask `bindVM` \sctxt -> (if _inLoop sctxt then pure () else errorVM1 (_ContinueOutsideLoop # getAnn a)) *> @@ -1006,7 +1006,7 @@ else pure ())) <*> validateWhitespace (getAnn a) ws validateSimpleStatementSyntax (Global a ws ids) = - ask `bindVM` \ctx -> + liftVM0 ask `bindVM` \ctx -> let params = ctx ^.. inFunction.folded.functionParams.folded in @@ -1022,8 +1022,8 @@ validateIdentSyntax i) ids validateSimpleStatementSyntax (Nonlocal a ws ids) = - ask `bindVM` \sctxt -> - get `bindVM` \nls -> + liftVM0 ask `bindVM` \sctxt -> + liftVM0 get `bindVM` \nls -> (case deleteFirstsBy' (\a -> (==) (a ^. unvalidated.identValue)) (ids ^.. folded.unvalidated) nls of [] -> pure () ids -> traverse_ (\e -> errorVM1 (_NoBindingNonlocal # e)) ids) *> diff --git a/test/Scope.hs b/test/Scope.hs --- a/test/Scope.hs +++ b/test/Scope.hs @@ -191,3 +191,47 @@ res <- fullyValidate st annotateShow res res === Failure (BadShadowing (MkIdent (Ann ()) "x" [Space]) :| []) + +prop_scope_12 :: Property +prop_scope_12 = + withTests 1 . property $ do + let + st = + _If # + (if_ none_ [line_ (var_ "x" .= 2)] & + else_ [line_ (var_ "y" .= var_ "x")]) + res <- fullyValidate st + annotateShow res + res === Failure (NotInScope (MkIdent (Ann ()) "x" []) :| []) + +prop_scope_13 :: Property +prop_scope_13 = + withTests 1 . property $ do + let + st = + _Fundef # + def_ "test" [] + [ line_ $ + if_ none_ [line_ (var_ "x" .= 1)] & + else_ [line_ (var_ "y" .= 2)] + , line_ $ var_ "x" + ] + res <- fullyValidate st + annotateShow res + res === Failure (FoundDynamic () (MkIdent (Ann ()) "x" []) :| []) + +prop_scope_14 :: Property +prop_scope_14 = + withTests 1 . property $ do + let + st = + _Fundef # + def_ "test" [] + [ line_ $ + if_ none_ [line_ (var_ "x" .= 1)] & + else_ [line_ (var_ "y" .= 2)] + , line_ $ var_ "y" + ] + res <- fullyValidate st + annotateShow res + res === Failure (FoundDynamic () (MkIdent (Ann ()) "y" []) :| [])