diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 3b51f79fd..f6d63f6f5 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -126,6 +126,25 @@ instance ( Addressable (LocationFor v) es instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = point x +newtype QualifiedIdentifier a = QualifiedIdentifier a + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) + +instance Eq1 QualifiedIdentifier where liftEq = genericLiftEq +instance Ord1 QualifiedIdentifier where liftCompare = genericLiftCompare +instance Show1 QualifiedIdentifier where liftShowsPrec = genericLiftShowsPrec + +instance ( Addressable (LocationFor v) es + , Member Fail es + , Member (Reader (EnvironmentFor v)) es + , Member (State (StoreFor v)) es + , FreeVariables t + ) => Evaluatable es t v QualifiedIdentifier where + eval (QualifiedIdentifier xs) = do + env <- ask + let name = qualifiedName (subterm xs) + maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env) + + newtype Program a = Program [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index a7aa80348..bd08810f0 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -195,35 +195,7 @@ instance Ord1 MemberAccess where liftCompare = genericLiftCompare instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for MemberAccess -instance ( FreeVariables t - , Ord l - , Show l - , Show t - , Show (Cell l (Value l t)) - , CellValue l (Value l t) - , Member Fail es - , Member (State (EnvironmentFor (Value l t))) es - , Member (Reader (EnvironmentFor (Value l t))) es - , Member (State (StoreFor (Value l t))) es - ) => Evaluatable es t (Value l t) MemberAccess where - eval (MemberAccess a b) = do - let scope = qualifiedName (subterm a) - env <- get @(EnvironmentFor (Value l t)) - case envLookup scope env of - Nothing -> fail ("qualified name not found: " <> show scope) - Just addr -> do - store <- get @(StoreFor (Value l t)) - case storeLookup addr store of - Nothing -> fail "address not found" - Just c -> do - let interface = val c - Interface _ env <- maybe - (fail ("expected an interface, but got: " <> show interface)) - pure - (prj interface :: Maybe (Interface l t)) - local (const env) (subtermValue b) - -instance Member Fail es => Evaluatable es t Type.Type MemberAccess where +instance Member Fail es => Evaluatable es t v MemberAccess -- | Subscript (e.g a[1]) data Subscript a diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs index ee5ee8997..264c93673 100644 --- a/src/Language/Python/Assignment.hs +++ b/src/Language/Python/Assignment.hs @@ -79,6 +79,7 @@ type Syntax = , Syntax.Empty , Syntax.Error , Syntax.Identifier + , Syntax.QualifiedIdentifier , Syntax.Program , Type.Annotation , [] @@ -451,8 +452,14 @@ slice = makeTerm <$> symbol Slice <*> children <*> (term expression <|> emptyTerm)) call :: Assignment -call = makeTerm <$> symbol Call <*> children (Expression.Call <$> pure [] <*> term expression <*> (symbol ArgumentList *> children (manyTerm expression) - <|> someTerm comprehension) <*> emptyTerm) +call = makeTerm <$> symbol Call <*> children (Expression.Call <$> pure [] <*> term qualifiedIdentifier <*> (symbol ArgumentList *> children (manyTerm expression) <|> someTerm comprehension) <*> emptyTerm) + where + qualifiedIdentifier = makeQualifiedIdentifier <$> symbol Attribute <*> children (some identifier) + <|> plainIdentifier + plainIdentifier = makeTerm <$> location <*> (Syntax.QualifiedIdentifier <$> identifier) + makeQualifiedIdentifier loc [x] = makeTerm loc (Syntax.QualifiedIdentifier x) + makeQualifiedIdentifier loc xs = makeTerm loc (Syntax.QualifiedIdentifier (makeTerm' loc (inj xs))) + boolean :: Assignment boolean = makeTerm <$> token Grammar.True <*> pure Literal.true