From 3d412f7d9ef689394ad6a6d884575dd148884d80 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 29 Aug 2018 13:47:44 -0400 Subject: [PATCH 01/72] Add ScopeGraph --- semantic.cabal | 1 + src/Data/Abstract/ScopeGraph.hs | 23 +++++++++++++++++++++++ 2 files changed, 24 insertions(+) create mode 100644 src/Data/Abstract/ScopeGraph.hs diff --git a/semantic.cabal b/semantic.cabal index db36837c1..bee3acbd3 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -70,6 +70,7 @@ library , Data.Abstract.Package , Data.Abstract.Path , Data.Abstract.Ref + , Data.Abstract.ScopeGraph , Data.Abstract.Value.Abstract , Data.Abstract.Value.Concrete , Data.Abstract.Value.Type diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs new file mode 100644 index 000000000..8cedf1091 --- /dev/null +++ b/src/Data/Abstract/ScopeGraph.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeOperators, GADTs, PolyKinds #-} +module Data.Abstract.ScopeGraph (concat, prepend)where + +import Prelude hiding (concat) + +import Data.Finite + +type Scope k = Finite k + +data (––>) s s' where + Empty :: s ––> s + -- TODO: `s` here was previously `Member s' (EdgesOf s)` + Cons :: Scope s -> Scope s' ––> Scope s'' -> Scope s ––> Scope s'' + +concat :: Scope s ––> Scope s' -> Scope s' ––> Scope s'' -> Scope s ––> Scope s'' +concat Empty s2 = s2 +concat (Cons a s1) s2 = (Cons a (concat s1 s2)) + +data (|>) s name where + Path :: Scope s ––> Scope s' -> name -> Scope s |> name + +prepend :: Scope s ––> Scope s' -> Scope s' |> name -> Scope s |> name +prepend p (Path p' name) = Path (concat p p') name From 01af82bf53541505a02a7ea5ce6adc053abceaf0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 4 Sep 2018 12:43:14 -0400 Subject: [PATCH 02/72] WIP --- semantic.cabal | 2 + src/Data/Abstract/Frame.hs | 19 +++++++++ src/Data/Abstract/ScopeGraph.hs | 64 +++++++++++++++++++++-------- src/Scope.hs | 73 +++++++++++++++++++++++++++++++++ 4 files changed, 142 insertions(+), 16 deletions(-) create mode 100644 src/Data/Abstract/Frame.hs create mode 100644 src/Scope.hs diff --git a/semantic.cabal b/semantic.cabal index bee3acbd3..4ff1943c4 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -62,6 +62,7 @@ library , Data.Abstract.Exports , Data.Abstract.FreeVariables , Data.Abstract.Heap + , Data.Abstract.Frame , Data.Abstract.Live , Data.Abstract.Module , Data.Abstract.ModuleTable @@ -245,6 +246,7 @@ library , tree-sitter-ruby , tree-sitter-typescript , tree-sitter-java + , type-combinators default-language: Haskell2010 default-extensions: DataKinds , DeriveFoldable diff --git a/src/Data/Abstract/Frame.hs b/src/Data/Abstract/Frame.hs new file mode 100644 index 000000000..312eccf21 --- /dev/null +++ b/src/Data/Abstract/Frame.hs @@ -0,0 +1,19 @@ +module Data.Abstract.Frame () where + + +newtype Heap address = Heap { unScope :: Monoidal.Map address (Frame address) } + deriving (Eq, Foldable, Lower, Monoid, Ord, Semigroup) + +data HeapFrame = HeapFrame { scopeId :: scopeId, []} + +newtype Heap scopeId = Heap { unHeap :: [scopeId] } + +data Frame address where + Frame :: address -> HeapTy address -> Frame address + +-- setSlot :: t -> value t heap -> Frame s scopes -> Heap scopes -> Heap scopes +-- setSlot d v f h = case lookup h f of +-- Just (slots, links) -> + +-- data Frame types scopes where +-- Frame :: Slots types scopes -> Links types scopes -> Frame types scopes diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 8cedf1091..536b63139 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -1,23 +1,55 @@ -{-# LANGUAGE TypeOperators, GADTs, PolyKinds #-} -module Data.Abstract.ScopeGraph (concat, prepend)where +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Abstract.ScopeGraph + ( Scope + , scopeLookup + , scopeLookupAll + , scopeInsert + , scopeDelete + , scopeInit + , scopeSize + , scopeRestrict + ) where -import Prelude hiding (concat) +import Data.Abstract.Live +import qualified Data.Map.Monoidal as Monoidal +import Data.Semigroup.Reducer +import Prologue -import Data.Finite +-- | A map of addresses onto cells holding their values. +newtype Scope address value = Scope { unScope :: Monoidal.Map address (address, Set value) } + deriving (Eq, Foldable, Lower, Monoid, Ord, Semigroup) -type Scope k = Finite k +-- | Look up the cell of values for an 'Address' in a 'Scope', if any. +scopeLookup :: Ord address => address -> Scope address value -> Maybe (Set value) +scopeLookup address = Monoidal.lookup address . unScope -data (––>) s s' where - Empty :: s ––> s - -- TODO: `s` here was previously `Member s' (EdgesOf s)` - Cons :: Scope s -> Scope s' ––> Scope s'' -> Scope s ––> Scope s'' +-- | Look up the list of values stored for a given address, if any. +scopeLookupAll :: Ord address => address -> Scope address value -> Maybe [value] +scopeLookupAll address = fmap toList . scopeLookup address -concat :: Scope s ––> Scope s' -> Scope s' ––> Scope s'' -> Scope s ––> Scope s'' -concat Empty s2 = s2 -concat (Cons a s1) s2 = (Cons a (concat s1 s2)) +-- | Append a value onto the cell for a given address, inserting a new cell if none existed. +scopeInsert :: (Ord address, Ord value) => address -> value -> Scope address value -> Scope address value +scopeInsert address value = flip snoc (address, value) -data (|>) s name where - Path :: Scope s ––> Scope s' -> name -> Scope s |> name +-- | Manually insert a cell into the scope at a given address. +scopeInit :: Ord address => address -> Set value -> Scope address value -> Scope address value +scopeInit address cell (Scope h) = Scope (Monoidal.insert address cell h) -prepend :: Scope s ––> Scope s' -> Scope s' |> name -> Scope s |> name -prepend p (Path p' name) = Path (concat p p') name +-- | The number of addresses extant in a 'Scope'. +scopeSize :: Scope address value -> Int +scopeSize = Monoidal.size . unScope + +-- | Restrict a 'Scope' to only those addresses in the given 'Live' set (in essence garbage collecting the rest). +scopeRestrict :: Ord address => Scope address value -> Live address -> Scope address value +scopeRestrict (Scope m) roots = Scope (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m) + +scopeDelete :: Ord address => address -> Scope address value -> Scope address value +scopeDelete addr = Scope . Monoidal.delete addr . unScope + +instance (Ord address, Ord value) => Reducer (address, value) (Scope address value) where + unit = Scope . unit + cons (addr, a) (Scope scope) = Scope (cons (addr, a) scope) + snoc (Scope scope) (addr, a) = Scope (snoc scope (addr, a)) + +instance (Show address, Show value) => Show (Scope address value) where + showsPrec d = showsUnaryWith showsPrec "Scope" d . map (second toList) . Monoidal.pairs . unScope diff --git a/src/Scope.hs b/src/Scope.hs new file mode 100644 index 000000000..d8b8452c8 --- /dev/null +++ b/src/Scope.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TypeOperators, PolyKinds, GADTs, TypeFamilies, UndecidableInstances, RankNTypes #-} +module Scope (declsOf, edgesOf, Scope, Graph) where + +import Data.Kind (Type) +import Data.Finite +import GHC.TypeLits + +-- Scope Graphs +-- Type aliases for scope identifiers (`Scope`) and scope graphs (`Graph`). +type Scope k = Finite k + +newtype Graph ty k = Graph { unGraph :: Scope k -> ([ty], [Scope k]) } + +declsOf :: Graph ty k -> Scope k -> [ty] +declsOf g = fst . unGraph g + +edgesOf :: Graph ty k -> Scope k -> [Scope k] +edgesOf g = snd . unGraph g + +type family Fst (k :: (m, n)) where + Fst '(a, b) = a + +-- type family EdgesOf (g :: Graph ty (k :: 'Nat)) (s :: y) :: [y] where +-- EdgesOf g s = Fst (g s) + +data (––>) x y where + Empty :: s ––> s + -- TODO: `s` here was previously `Member s' (EdgesOf s)` + Cons :: s -> s' ––> s'' -> s ––> s'' + +concat :: s ––> s' -> s' ––> s'' -> s ––> s'' +concat Empty s2 = s2 +concat (Cons a s1) s2 = (Cons a (Scope.concat s1 s2)) + +data (|>) s name where + Path :: s ––> s' -> name -> s |> name + +prepend :: s ––> s' -> s' |> name -> s |> name +prepend p (Path p' name) = Path (Scope.concat p p') name + +type HeapTy address = [address] + +type HeapTy k = [Scope k] + +data FramePtr address where + FramePtr :: address -> HeapTy address -> FramePtr address + +data Slots ty address where + Slots :: [ty] -> HeapTy address -> Slots ty address + +data Links address where + Links :: [address] -> HeapTy address -> Links address + +data HeapFrame address where + HeapFrame :: Scope address -> HeapTy address -> HeapFrame address + +data Heap address where + Heap :: HeapTy address -> Heap address + + +-- Store frames in the heap +-- Lookup frame in the scope graph for a resolution path +-- Apply resolution path in the heap to get the value of a probably well-typed address. +-- Environment may be subsumed by a Reader of the current scope in the scope graph. +-- The scope graph is probably the primary data structure. +-- We shouldn't be concerned with the shapes of the frames as long as they correspond to the correct side-effects. + + +-- Figure out how to look up names in the scope graph + + +-- data Scope m a where +-- GetFrame :: s ––> s' -> Frame s e -> Heap e -> Scope m (Frame s' e) From 7e56ae520dff4bae4edfd88e29d93533ce325671 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 7 Sep 2018 17:53:09 -0400 Subject: [PATCH 03/72] Implement frames --- src/Data/Abstract/Frame.hs | 10 --- src/Data/Abstract/ScopeGraph.hs | 136 +++++++++++++++++++++++--------- 2 files changed, 99 insertions(+), 47 deletions(-) diff --git a/src/Data/Abstract/Frame.hs b/src/Data/Abstract/Frame.hs index 312eccf21..7ab14b247 100644 --- a/src/Data/Abstract/Frame.hs +++ b/src/Data/Abstract/Frame.hs @@ -1,16 +1,6 @@ module Data.Abstract.Frame () where -newtype Heap address = Heap { unScope :: Monoidal.Map address (Frame address) } - deriving (Eq, Foldable, Lower, Monoid, Ord, Semigroup) - -data HeapFrame = HeapFrame { scopeId :: scopeId, []} - -newtype Heap scopeId = Heap { unHeap :: [scopeId] } - -data Frame address where - Frame :: address -> HeapTy address -> Frame address - -- setSlot :: t -> value t heap -> Frame s scopes -> Heap scopes -> Heap scopes -- setSlot d v f h = case lookup h f of -- Just (slots, links) -> diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 536b63139..7790c4c4e 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -1,55 +1,117 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} module Data.Abstract.ScopeGraph - ( Scope + ( ScopeGraph + , Path + , Reference + , Declaration + , EdgeLabel + , Heap + , frameLookup , scopeLookup - , scopeLookupAll - , scopeInsert - , scopeDelete - , scopeInit - , scopeSize - , scopeRestrict + , frameSlots + , frameLinks + , getSlot + , setSlot + , lookup ) where import Data.Abstract.Live import qualified Data.Map.Monoidal as Monoidal +import qualified Data.Map.Strict as Map import Data.Semigroup.Reducer import Prologue +import Prelude hiding (lookup) --- | A map of addresses onto cells holding their values. -newtype Scope address value = Scope { unScope :: Monoidal.Map address (address, Set value) } - deriving (Eq, Foldable, Lower, Monoid, Ord, Semigroup) +data Scope scopeAddress name term ddata = Scope { + edges :: Map EdgeLabel [scopeAddress] + , references :: Map (Reference name term) (Path scopeAddress name term) + , declarations :: Map (Declaration name term) ddata +} --- | Look up the cell of values for an 'Address' in a 'Scope', if any. -scopeLookup :: Ord address => address -> Scope address value -> Maybe (Set value) -scopeLookup address = Monoidal.lookup address . unScope +newtype ScopeGraph scopeAddress name term ddata = ScopeGraph { unScopeGraph :: Map scopeAddress (Scope scopeAddress name term ddata) } --- | Look up the list of values stored for a given address, if any. -scopeLookupAll :: Ord address => address -> Scope address value -> Maybe [value] -scopeLookupAll address = fmap toList . scopeLookup address +data Path scopeAddress name term where + DPath :: Declaration name term -> Path scopeAddress name term + EPath :: EdgeLabel -> scopeAddress -> (Path scopeAddress name syntax) -> Path scopeAddress name term --- | Append a value onto the cell for a given address, inserting a new cell if none existed. -scopeInsert :: (Ord address, Ord value) => address -> value -> Scope address value -> Scope address value -scopeInsert address value = flip snoc (address, value) +data Reference name term = Reference name term --- | Manually insert a cell into the scope at a given address. -scopeInit :: Ord address => address -> Set value -> Scope address value -> Scope address value -scopeInit address cell (Scope h) = Scope (Monoidal.insert address cell h) +data Declaration name term = Declaration name term --- | The number of addresses extant in a 'Scope'. -scopeSize :: Scope address value -> Int -scopeSize = Monoidal.size . unScope +data EdgeLabel = P | I + deriving (Eq, Ord, Show) --- | Restrict a 'Scope' to only those addresses in the given 'Live' set (in essence garbage collecting the rest). -scopeRestrict :: Ord address => Scope address value -> Live address -> Scope address value -scopeRestrict (Scope m) roots = Scope (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m) +data Frame scopeAddress frameAddress declaration value = Frame { + scopeAddress :: scopeAddress + , links :: Map EdgeLabel (Map scopeAddress frameAddress) + , slots :: Map declaration value + } -scopeDelete :: Ord address => address -> Scope address value -> Scope address value -scopeDelete addr = Scope . Monoidal.delete addr . unScope +newtype Heap scopeAddress frameAddress declaration value = Heap { unHeap :: Monoidal.Map frameAddress (Frame scopeAddress frameAddress declaration value) } -instance (Ord address, Ord value) => Reducer (address, value) (Scope address value) where - unit = Scope . unit - cons (addr, a) (Scope scope) = Scope (cons (addr, a) scope) - snoc (Scope scope) (addr, a) = Scope (snoc scope (addr, a)) +-- | Look up the frame for an 'address' in a 'Heap', if any. +frameLookup :: Ord address => address -> Heap scope address declaration value -> Maybe (Frame scope address declaration value) +frameLookup address = Monoidal.lookup address . unHeap -instance (Show address, Show value) => Show (Scope address value) where - showsPrec d = showsUnaryWith showsPrec "Scope" d . map (second toList) . Monoidal.pairs . unScope +-- | Look up the scope address for a given frame address. +scopeLookup :: Ord address => address -> Heap scope address declaration value -> Maybe scope +scopeLookup address = fmap scopeAddress . frameLookup address + +frameSlots :: Ord address => address -> Heap scope address declaration value -> Maybe (Map declaration value) +frameSlots address = fmap slots . frameLookup address + +frameLinks :: Ord address => address -> Heap scope address declaration value -> Maybe (Map EdgeLabel (Map scope address)) +frameLinks address = fmap links . frameLookup address + +getSlot :: (Ord address, Ord declaration) => address -> Heap scope address declaration value -> declaration -> Maybe value +getSlot address heap declaration = do + slotMap <- frameSlots address heap + Map.lookup declaration slotMap + +setSlot :: (Ord address, Ord declaration) => Heap scope address declaration value -> address -> declaration -> value -> Heap scope address declaration value +setSlot heap address declaration value = + case frameLookup address heap of + Just frame -> let slotMap = slots frame in + Heap $ Monoidal.insert address (frame { slots = (Map.insert declaration value slotMap) }) (unHeap heap) + Nothing -> heap + +lookup :: (Ord address, Ord scope) => Heap scope address declaration value -> address -> (Path scope name term) -> declaration -> Maybe scope +lookup heap address (DPath d) declaration = scopeLookup address heap +lookup heap address (EPath label scope path) declaration = do + frame <- frameLookup address heap + scopeMap <- Map.lookup label (links frame) + nextAddress <- Map.lookup scope scopeMap + lookup heap address path declaration + + + +-- -- | Look up the list of values stored for a given address, if any. +-- scopeLookupAll :: Ord address => address -> Heap address value -> Maybe [value] +-- scopeLookupAll address = fmap toList . scopeLookup address + +-- -- | Append a value onto the cell for a given address, inserting a new cell if none existed. +-- scopeInsert :: (Ord address, Ord value) => address -> value -> Scope address value -> Scope address value +-- scopeInsert address value = flip snoc (address, value) + +-- -- | Manually insert a cell into the scope at a given address. +-- scopeInit :: Ord address => address -> Set value -> Scope address value -> Scope address value +-- scopeInit address cell (Scope h) = Scope (Monoidal.insert address cell h) + +-- -- | The number of addresses extant in a 'Scope'. +-- scopeSize :: Scope address value -> Int +-- scopeSize = Monoidal.size . unScope + +-- -- | Restrict a 'Scope' to only those addresses in the given 'Live' set (in essence garbage collecting the rest). +-- scopeRestrict :: Ord address => Scope address value -> Live address -> Scope address value +-- scopeRestrict (Scope m) roots = Scope (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m) + +-- scopeDelete :: Ord address => address -> Scope address value -> Scope address value +-- scopeDelete addr = Scope . Monoidal.delete addr . unScope + +-- instance (Ord address, Ord value) => Reducer (address, value) (Scope address value) where +-- unit = Scope . unit +-- cons (addr, a) (Scope scope) = Scope (cons (addr, a) scope) +-- snoc (Scope scope) (addr, a) = Scope (snoc scope (addr, a)) + +-- instance (Show address, Show value) => Show (Scope address value) where +-- showsPrec d = showsUnaryWith showsPrec "Scope" d . map (second toList) . Monoidal.pairs . unScope From 6c9392514b9a839106c7163ddaa4cbfc763df6d0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 7 Sep 2018 18:01:07 -0400 Subject: [PATCH 04/72] Look up the declaration one frame up --- src/Data/Abstract/ScopeGraph.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 7790c4c4e..002a789a8 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -81,8 +81,7 @@ lookup heap address (EPath label scope path) declaration = do frame <- frameLookup address heap scopeMap <- Map.lookup label (links frame) nextAddress <- Map.lookup scope scopeMap - lookup heap address path declaration - + lookup heap nextAddress path declaration -- -- | Look up the list of values stored for a given address, if any. From 31040fa553f57f204beed4924772e5980e075e54 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 7 Sep 2018 18:55:51 -0400 Subject: [PATCH 05/72] add frame insertion --- src/Data/Abstract/ScopeGraph.hs | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 002a789a8..6c7163a0b 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -68,8 +68,8 @@ getSlot address heap declaration = do slotMap <- frameSlots address heap Map.lookup declaration slotMap -setSlot :: (Ord address, Ord declaration) => Heap scope address declaration value -> address -> declaration -> value -> Heap scope address declaration value -setSlot heap address declaration value = +setSlot :: (Ord address, Ord declaration) => address -> declaration -> value -> Heap scope address declaration value -> Heap scope address declaration value +setSlot address declaration value heap = case frameLookup address heap of Just frame -> let slotMap = slots frame in Heap $ Monoidal.insert address (frame { slots = (Map.insert declaration value slotMap) }) (unHeap heap) @@ -83,6 +83,20 @@ lookup heap address (EPath label scope path) declaration = do nextAddress <- Map.lookup scope scopeMap lookup heap nextAddress path declaration +newFrame :: (Ord address, Ord declaration) => scope -> address -> Map EdgeLabel (Map scope address) -> Heap scope address declaration value -> Heap scope address declaration value +newFrame scope address links = insertFrame address (Frame scope links mempty) + +initFrame :: (Ord address, Ord declaration, Ord scope) => scope -> address -> Map EdgeLabel (Map scope address) -> Map declaration value -> Heap scope address declaration value -> Heap scope address declaration value +initFrame scope address links slots = fillFrame address slots . newFrame scope address links + +insertFrame :: Ord address => address -> Frame scope address declaration value -> Heap scope address declaration value -> Heap scope address declaration value +insertFrame address frame = Heap . Monoidal.insert address frame . unHeap + +fillFrame :: Ord address => address -> Map declaration value -> Heap scope address declaration value -> Heap scope address declaration value +fillFrame address slots heap = + case frameLookup address heap of + Just frame -> insertFrame address (frame { slots = slots }) heap + Nothing -> heap -- -- | Look up the list of values stored for a given address, if any. -- scopeLookupAll :: Ord address => address -> Heap address value -> Maybe [value] From 448d94aa8f62647a2b9a85d0810b5dc4ab56944d Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 7 Sep 2018 19:46:07 -0400 Subject: [PATCH 06/72] add deleting and heap sizes --- src/Data/Abstract/ScopeGraph.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 6c7163a0b..aa77cc1bb 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -98,6 +98,13 @@ fillFrame address slots heap = Just frame -> insertFrame address (frame { slots = slots }) heap Nothing -> heap +deleteFrame :: Ord address => address -> Heap scope address declaration value -> Heap scope address declaration value +deleteFrame address = Heap . Monoidal.delete address . unHeap + +-- | The number of frames in the `Heap`. +heapSize :: Heap scope address declaration value -> Int +heapSize = Monoidal.size . unHeap + -- -- | Look up the list of values stored for a given address, if any. -- scopeLookupAll :: Ord address => address -> Heap address value -> Maybe [value] -- scopeLookupAll address = fmap toList . scopeLookup address From a1a2df12414c73c8937a0d550adb8ecee83c0c05 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 10 Sep 2018 16:17:57 -0400 Subject: [PATCH 07/72] Implement scope graphs --- src/Data/Abstract/ScopeGraph.hs | 45 +++++++++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index aa77cc1bb..3e42c26f6 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -32,11 +32,52 @@ newtype ScopeGraph scopeAddress name term ddata = ScopeGraph { unScopeGraph :: M data Path scopeAddress name term where DPath :: Declaration name term -> Path scopeAddress name term - EPath :: EdgeLabel -> scopeAddress -> (Path scopeAddress name syntax) -> Path scopeAddress name term + EPath :: EdgeLabel -> scopeAddress -> (Path scopeAddress name term) -> Path scopeAddress name term + +pathDeclaration :: Path scope name term -> Declaration name term +pathDeclaration (DPath d) = d +pathDeclaration (EPath _ _ p) = pathDeclaration p + +pathsOfScope :: Ord scope => scope -> ScopeGraph scope name term ddata -> Maybe (Map (Reference name term) (Path scope name term)) +pathsOfScope scope = fmap references . Map.lookup scope . unScopeGraph + +ddataOfScope :: Ord scope => scope -> ScopeGraph scope name term ddata -> Maybe (Map (Declaration name term) ddata) +ddataOfScope scope = fmap declarations . Map.lookup scope . unScopeGraph + +linksOfScope :: Ord scope => scope -> ScopeGraph scope name term ddata -> Maybe (Map EdgeLabel [scope]) +linksOfScope scope = fmap edges . Map.lookup scope . unScopeGraph + +scopeOfRef :: (Ord name, Ord term, Ord scope) => (Reference name term) -> ScopeGraph scope name term ddata -> Maybe scope +scopeOfRef ref graph = go $ Map.keys (unScopeGraph graph) + where + go (s : scopes') = case pathsOfScope s graph of + Just pathMap -> case Map.lookup ref pathMap of + Just _ -> Just s + Nothing -> go scopes' + Nothing -> go scopes' + go [] = Nothing + +pathOfRef :: (Ord name, Ord term, Ord scope) => (Reference name term) -> ScopeGraph scope name term ddata -> Maybe (Path scope name term) +pathOfRef ref graph = do + scope <- scopeOfRef ref graph + pathsMap <- pathsOfScope scope graph + Map.lookup ref pathsMap + +scopeOfDeclaration :: (Ord name, Ord term, Ord scope) => Declaration name term -> ScopeGraph scope name term ddata -> Maybe scope +scopeOfDeclaration declaration graph = go $ Map.keys (unScopeGraph graph) + where + go (s : scopes') = case ddataOfScope s graph of + Just ddataMap -> case Map.lookup declaration ddataMap of + Just _ -> Just s + Nothing -> go scopes' + Nothing -> go scopes' + go [] = Nothing data Reference name term = Reference name term + deriving (Eq, Ord, Show) data Declaration name term = Declaration name term + deriving (Eq, Ord, Show) data EdgeLabel = P | I deriving (Eq, Ord, Show) @@ -86,7 +127,7 @@ lookup heap address (EPath label scope path) declaration = do newFrame :: (Ord address, Ord declaration) => scope -> address -> Map EdgeLabel (Map scope address) -> Heap scope address declaration value -> Heap scope address declaration value newFrame scope address links = insertFrame address (Frame scope links mempty) -initFrame :: (Ord address, Ord declaration, Ord scope) => scope -> address -> Map EdgeLabel (Map scope address) -> Map declaration value -> Heap scope address declaration value -> Heap scope address declaration value +initFrame :: (Ord address, Ord declaration) => scope -> address -> Map EdgeLabel (Map scope address) -> Map declaration value -> Heap scope address declaration value -> Heap scope address declaration value initFrame scope address links slots = fillFrame address slots . newFrame scope address links insertFrame :: Ord address => address -> Frame scope address declaration value -> Heap scope address declaration value -> Heap scope address declaration value From 1eac23ce2e1f15dbb8a93a0b1c6a2d74b678215f Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 10 Sep 2018 18:50:40 -0400 Subject: [PATCH 08/72] Don't parameterize scopes by name --- semantic.cabal | 1 + src/Data/Abstract/ScopeGraph.hs | 80 ++++++++++++++++++--------------- 2 files changed, 46 insertions(+), 35 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index 8937bb30e..0c8d1afeb 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -46,6 +46,7 @@ library , Control.Abstract.Primitive , Control.Abstract.PythonPackage , Control.Abstract.Roots + , Control.Abstract.ScopeGraph , Control.Abstract.TermEvaluator , Control.Abstract.Value -- Datatypes for abstract interpretation diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 3e42c26f6..602736fb5 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -1,11 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} module Data.Abstract.ScopeGraph - ( ScopeGraph + ( ScopeGraph(..) , Path - , Reference - , Declaration - , EdgeLabel - , Heap + , Reference + , Declaration + , EdgeLabel + , Heap , frameLookup , scopeLookup , frameSlots @@ -13,41 +13,51 @@ module Data.Abstract.ScopeGraph , getSlot , setSlot , lookup + , scopeOfRef ) where +import Data.Abstract.Name import Data.Abstract.Live -import qualified Data.Map.Monoidal as Monoidal import qualified Data.Map.Strict as Map import Data.Semigroup.Reducer import Prologue import Prelude hiding (lookup) -data Scope scopeAddress name term ddata = Scope { +data Scope scopeAddress term ddata = Scope { edges :: Map EdgeLabel [scopeAddress] - , references :: Map (Reference name term) (Path scopeAddress name term) - , declarations :: Map (Declaration name term) ddata -} + , references :: Map (Reference term) (Path scopeAddress term) + , declarations :: Map (Declaration term) ddata + } deriving (Eq, Show, Ord) -newtype ScopeGraph scopeAddress name term ddata = ScopeGraph { unScopeGraph :: Map scopeAddress (Scope scopeAddress name term ddata) } -data Path scopeAddress name term where - DPath :: Declaration name term -> Path scopeAddress name term - EPath :: EdgeLabel -> scopeAddress -> (Path scopeAddress name term) -> Path scopeAddress name term +newtype ScopeGraph scopeAddress term ddata = ScopeGraph { unScopeGraph :: Map scopeAddress (Scope scopeAddress term ddata) } -pathDeclaration :: Path scope name term -> Declaration name term +deriving instance (Eq address, Eq term, Eq ddata) => Eq (ScopeGraph address term ddata) +deriving instance (Show address, Show term, Show ddata) => Show (ScopeGraph address term ddata) +deriving instance (Ord address, Ord term, Ord ddata) => Ord (ScopeGraph address term ddata) + +data Path scopeAddress term where + DPath :: Declaration term -> Path scopeAddress term + EPath :: EdgeLabel -> scopeAddress -> (Path scopeAddress term) -> Path scopeAddress term + +deriving instance (Eq scope, Eq term) => Eq (Path scope term) +deriving instance (Show scope, Show term) => Show (Path scope term) +deriving instance (Ord scope, Ord term) => Ord (Path scope term) + +pathDeclaration :: Path scope term -> Declaration term pathDeclaration (DPath d) = d pathDeclaration (EPath _ _ p) = pathDeclaration p -pathsOfScope :: Ord scope => scope -> ScopeGraph scope name term ddata -> Maybe (Map (Reference name term) (Path scope name term)) +pathsOfScope :: Ord scope => scope -> ScopeGraph scope term ddata -> Maybe (Map (Reference term) (Path scope term)) pathsOfScope scope = fmap references . Map.lookup scope . unScopeGraph -ddataOfScope :: Ord scope => scope -> ScopeGraph scope name term ddata -> Maybe (Map (Declaration name term) ddata) +ddataOfScope :: Ord scope => scope -> ScopeGraph scope term ddata -> Maybe (Map (Declaration term) ddata) ddataOfScope scope = fmap declarations . Map.lookup scope . unScopeGraph -linksOfScope :: Ord scope => scope -> ScopeGraph scope name term ddata -> Maybe (Map EdgeLabel [scope]) +linksOfScope :: Ord scope => scope -> ScopeGraph scope term ddata -> Maybe (Map EdgeLabel [scope]) linksOfScope scope = fmap edges . Map.lookup scope . unScopeGraph -scopeOfRef :: (Ord name, Ord term, Ord scope) => (Reference name term) -> ScopeGraph scope name term ddata -> Maybe scope +scopeOfRef :: (Ord term, Ord scope) => Reference term -> ScopeGraph scope term ddata -> Maybe scope scopeOfRef ref graph = go $ Map.keys (unScopeGraph graph) where go (s : scopes') = case pathsOfScope s graph of @@ -57,13 +67,13 @@ scopeOfRef ref graph = go $ Map.keys (unScopeGraph graph) Nothing -> go scopes' go [] = Nothing -pathOfRef :: (Ord name, Ord term, Ord scope) => (Reference name term) -> ScopeGraph scope name term ddata -> Maybe (Path scope name term) +pathOfRef :: (Ord term, Ord scope) => Reference term -> ScopeGraph scope term ddata -> Maybe (Path scope term) pathOfRef ref graph = do scope <- scopeOfRef ref graph pathsMap <- pathsOfScope scope graph Map.lookup ref pathsMap -scopeOfDeclaration :: (Ord name, Ord term, Ord scope) => Declaration name term -> ScopeGraph scope name term ddata -> Maybe scope +scopeOfDeclaration :: (Ord term, Ord scope) => Declaration term -> ScopeGraph scope term ddata -> Maybe scope scopeOfDeclaration declaration graph = go $ Map.keys (unScopeGraph graph) where go (s : scopes') = case ddataOfScope s graph of @@ -73,10 +83,10 @@ scopeOfDeclaration declaration graph = go $ Map.keys (unScopeGraph graph) Nothing -> go scopes' go [] = Nothing -data Reference name term = Reference name term +data Reference term = Reference Name term deriving (Eq, Ord, Show) -data Declaration name term = Declaration name term +data Declaration term = Declaration Name term deriving (Eq, Ord, Show) data EdgeLabel = P | I @@ -88,11 +98,11 @@ data Frame scopeAddress frameAddress declaration value = Frame { , slots :: Map declaration value } -newtype Heap scopeAddress frameAddress declaration value = Heap { unHeap :: Monoidal.Map frameAddress (Frame scopeAddress frameAddress declaration value) } +newtype Heap scopeAddress frameAddress declaration value = Heap { unHeap :: Map frameAddress (Frame scopeAddress frameAddress declaration value) } -- | Look up the frame for an 'address' in a 'Heap', if any. frameLookup :: Ord address => address -> Heap scope address declaration value -> Maybe (Frame scope address declaration value) -frameLookup address = Monoidal.lookup address . unHeap +frameLookup address = Map.lookup address . unHeap -- | Look up the scope address for a given frame address. scopeLookup :: Ord address => address -> Heap scope address declaration value -> Maybe scope @@ -113,10 +123,10 @@ setSlot :: (Ord address, Ord declaration) => address -> declaration -> value -> setSlot address declaration value heap = case frameLookup address heap of Just frame -> let slotMap = slots frame in - Heap $ Monoidal.insert address (frame { slots = (Map.insert declaration value slotMap) }) (unHeap heap) + Heap $ Map.insert address (frame { slots = (Map.insert declaration value slotMap) }) (unHeap heap) Nothing -> heap -lookup :: (Ord address, Ord scope) => Heap scope address declaration value -> address -> (Path scope name term) -> declaration -> Maybe scope +lookup :: (Ord address, Ord scope) => Heap scope address declaration value -> address -> (Path scope term) -> declaration -> Maybe scope lookup heap address (DPath d) declaration = scopeLookup address heap lookup heap address (EPath label scope path) declaration = do frame <- frameLookup address heap @@ -131,7 +141,7 @@ initFrame :: (Ord address, Ord declaration) => scope -> address -> Map EdgeLabel initFrame scope address links slots = fillFrame address slots . newFrame scope address links insertFrame :: Ord address => address -> Frame scope address declaration value -> Heap scope address declaration value -> Heap scope address declaration value -insertFrame address frame = Heap . Monoidal.insert address frame . unHeap +insertFrame address frame = Heap . Map.insert address frame . unHeap fillFrame :: Ord address => address -> Map declaration value -> Heap scope address declaration value -> Heap scope address declaration value fillFrame address slots heap = @@ -140,11 +150,11 @@ fillFrame address slots heap = Nothing -> heap deleteFrame :: Ord address => address -> Heap scope address declaration value -> Heap scope address declaration value -deleteFrame address = Heap . Monoidal.delete address . unHeap +deleteFrame address = Heap . Map.delete address . unHeap -- | The number of frames in the `Heap`. heapSize :: Heap scope address declaration value -> Int -heapSize = Monoidal.size . unHeap +heapSize = Map.size . unHeap -- -- | Look up the list of values stored for a given address, if any. -- scopeLookupAll :: Ord address => address -> Heap address value -> Maybe [value] @@ -156,18 +166,18 @@ heapSize = Monoidal.size . unHeap -- -- | Manually insert a cell into the scope at a given address. -- scopeInit :: Ord address => address -> Set value -> Scope address value -> Scope address value --- scopeInit address cell (Scope h) = Scope (Monoidal.insert address cell h) +-- scopeInit address cell (Scope h) = Scope (Map.insert address cell h) -- -- | The number of addresses extant in a 'Scope'. -- scopeSize :: Scope address value -> Int --- scopeSize = Monoidal.size . unScope +-- scopeSize = Map.size . unScope -- -- | Restrict a 'Scope' to only those addresses in the given 'Live' set (in essence garbage collecting the rest). -- scopeRestrict :: Ord address => Scope address value -> Live address -> Scope address value --- scopeRestrict (Scope m) roots = Scope (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m) +-- scopeRestrict (Scope m) roots = Scope (Map.filterWithKey (\ address _ -> address `liveMember` roots) m) -- scopeDelete :: Ord address => address -> Scope address value -> Scope address value --- scopeDelete addr = Scope . Monoidal.delete addr . unScope +-- scopeDelete addr = Scope . Map.delete addr . unScope -- instance (Ord address, Ord value) => Reducer (address, value) (Scope address value) where -- unit = Scope . unit @@ -175,4 +185,4 @@ heapSize = Monoidal.size . unHeap -- snoc (Scope scope) (addr, a) = Scope (snoc scope (addr, a)) -- instance (Show address, Show value) => Show (Scope address value) where --- showsPrec d = showsUnaryWith showsPrec "Scope" d . map (second toList) . Monoidal.pairs . unScope +-- showsPrec d = showsUnaryWith showsPrec "Scope" d . map (second toList) . Map.pairs . unScope From 3fa0a07585379efe95eccf4354a3a05da864544b Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 10 Sep 2018 18:50:51 -0400 Subject: [PATCH 09/72] add a ScopeEnv effect --- src/Control/Abstract/ScopeGraph.hs | 31 ++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 src/Control/Abstract/ScopeGraph.hs diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs new file mode 100644 index 000000000..cd8124cbb --- /dev/null +++ b/src/Control/Abstract/ScopeGraph.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE LambdaCase, TypeOperators, GADTs, KindSignatures, ScopedTypeVariables, RankNTypes #-} +module Control.Abstract.ScopeGraph where + +import Data.Abstract.ScopeGraph as ScopeGraph +import Data.Semilattice.Lower +import Control.Monad.Effect +import Control.Abstract.Evaluator + +data ScopeEnv address (m :: * -> *) a where + Lookup :: Reference term -> ScopeEnv address m (Maybe scope) + Declare :: Declaration term -> ScopeEnv address m () + Reference :: Reference term -> Declaration term -> ScopeEnv address m () + +instance PureEffect (ScopeEnv address) +instance Effect (ScopeEnv address) where + handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) + handleState c dist (Request (Declare decl) k) = Request (Declare decl) (dist . (<$ c) . k) + handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k) + +runScopeEnv :: (Ord scope, Ord term, Effects effects) + => Evaluator address value (ScopeEnv scope ': effects) a + -> Evaluator address value effects (ScopeGraph scope term ddata, a) +runScopeEnv = runState (ScopeGraph mempty) . reinterpret handleScopeEnv + +handleScopeEnv :: forall scope address term ddata value effects a. (Ord term, Effects effects) + => ScopeEnv scope (Eff (ScopeEnv scope ': effects)) a + -> Evaluator address value (State (ScopeGraph scope term ddata) ': effects) a +handleScopeEnv = \case + Lookup ref -> do + graph <- get @(ScopeGraph scope term ddata) + pure (ScopeGraph.scopeOfRef ref graph) From 287a7e8b7ff2e63ed59a912500ebbc52be0c458c Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 11 Sep 2018 18:24:23 -0400 Subject: [PATCH 10/72] Add declare to ScopeEnv --- src/Control/Abstract/ScopeGraph.hs | 40 +++++++----- src/Data/Abstract/ScopeGraph.hs | 100 +++++++++++++++++------------ 2 files changed, 83 insertions(+), 57 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index cd8124cbb..3b329560f 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -2,30 +2,38 @@ module Control.Abstract.ScopeGraph where import Data.Abstract.ScopeGraph as ScopeGraph -import Data.Semilattice.Lower import Control.Monad.Effect import Control.Abstract.Evaluator -data ScopeEnv address (m :: * -> *) a where - Lookup :: Reference term -> ScopeEnv address m (Maybe scope) - Declare :: Declaration term -> ScopeEnv address m () - Reference :: Reference term -> Declaration term -> ScopeEnv address m () +data ScopeEnv address ddata (m :: * -> *) a where + Lookup :: Reference -> ScopeEnv address ddata m (Maybe address) + Declare :: Declaration -> ddata -> ScopeEnv address ddata m () + Reference :: Reference -> Declaration -> ScopeEnv address ddata m () -instance PureEffect (ScopeEnv address) -instance Effect (ScopeEnv address) where +instance PureEffect (ScopeEnv address ddata) +instance Effect (ScopeEnv address ddata) where handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) - handleState c dist (Request (Declare decl) k) = Request (Declare decl) (dist . (<$ c) . k) + handleState c dist (Request (Declare decl ddata) k) = Request (Declare decl ddata) (dist . (<$ c) . k) handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k) -runScopeEnv :: (Ord scope, Ord term, Effects effects) - => Evaluator address value (ScopeEnv scope ': effects) a - -> Evaluator address value effects (ScopeGraph scope term ddata, a) -runScopeEnv = runState (ScopeGraph mempty) . reinterpret handleScopeEnv +runScopeEnv :: (Ord scope, Effects effects) + => scope + -> Evaluator address value (ScopeEnv scope ddata ': effects) a + -> Evaluator address value effects (ScopeGraph scope ddata, a) +runScopeEnv scope = runState (ScopeGraph.emptyGraph scope) . reinterpret handleScopeEnv -handleScopeEnv :: forall scope address term ddata value effects a. (Ord term, Effects effects) - => ScopeEnv scope (Eff (ScopeEnv scope ': effects)) a - -> Evaluator address value (State (ScopeGraph scope term ddata) ': effects) a +handleScopeEnv :: forall scope address ddata value effects a. (Ord scope) + => ScopeEnv scope ddata (Eff (ScopeEnv scope ddata ': effects)) a + -> Evaluator address value (State (ScopeGraph scope ddata) ': effects) a handleScopeEnv = \case Lookup ref -> do - graph <- get @(ScopeGraph scope term ddata) + graph <- get @(ScopeGraph scope ddata) pure (ScopeGraph.scopeOfRef ref graph) + Declare decl ddata -> do + graph <- get + put @(ScopeGraph scope ddata) (ScopeGraph.declare decl ddata graph) + pure () + Reference ref decl -> do + graph <- get + put @(ScopeGraph scope ddata) (ScopeGraph.reference reference decl graph) + pure () diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 602736fb5..48e20b4aa 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} module Data.Abstract.ScopeGraph ( ScopeGraph(..) , Path @@ -14,79 +14,97 @@ module Data.Abstract.ScopeGraph , setSlot , lookup , scopeOfRef + , declare + , emptyGraph ) where -import Data.Abstract.Name -import Data.Abstract.Live +import Data.Abstract.Live +import Data.Abstract.Name import qualified Data.Map.Strict as Map -import Data.Semigroup.Reducer -import Prologue -import Prelude hiding (lookup) +import Data.Semigroup.Reducer +import Prelude hiding (lookup) +import Prologue -data Scope scopeAddress term ddata = Scope { - edges :: Map EdgeLabel [scopeAddress] - , references :: Map (Reference term) (Path scopeAddress term) - , declarations :: Map (Declaration term) ddata +data Scope scopeAddress ddata = Scope { + edges :: Map EdgeLabel [scopeAddress] + , references :: Map Reference (Path scopeAddress) + , declarations :: Map Declaration ddata } deriving (Eq, Show, Ord) -newtype ScopeGraph scopeAddress term ddata = ScopeGraph { unScopeGraph :: Map scopeAddress (Scope scopeAddress term ddata) } +data ScopeGraph scope ddata = ScopeGraph { unScopeGraph :: (Map scope (Scope scope ddata), scope) } -deriving instance (Eq address, Eq term, Eq ddata) => Eq (ScopeGraph address term ddata) -deriving instance (Show address, Show term, Show ddata) => Show (ScopeGraph address term ddata) -deriving instance (Ord address, Ord term, Ord ddata) => Ord (ScopeGraph address term ddata) +emptyGraph :: scope -> ScopeGraph scope ddata +emptyGraph scope = ScopeGraph (Map.singleton scope (Scope mempty mempty mempty), scope) -data Path scopeAddress term where - DPath :: Declaration term -> Path scopeAddress term - EPath :: EdgeLabel -> scopeAddress -> (Path scopeAddress term) -> Path scopeAddress term +deriving instance (Eq address, Eq ddata) => Eq (ScopeGraph address ddata) +deriving instance (Show address, Show ddata) => Show (ScopeGraph address ddata) +deriving instance (Ord address, Ord ddata) => Ord (ScopeGraph address ddata) -deriving instance (Eq scope, Eq term) => Eq (Path scope term) -deriving instance (Show scope, Show term) => Show (Path scope term) -deriving instance (Ord scope, Ord term) => Ord (Path scope term) +data Path scopeAddress where + DPath :: Declaration -> Path scopeAddress + EPath :: EdgeLabel -> scopeAddress -> Path scopeAddress -> Path scopeAddress -pathDeclaration :: Path scope term -> Declaration term -pathDeclaration (DPath d) = d +deriving instance Eq scope => Eq (Path scope) +deriving instance Show scope => Show (Path scope) +deriving instance Ord scope => Ord (Path scope) + +pathDeclaration :: Path scope -> Declaration +pathDeclaration (DPath d) = d pathDeclaration (EPath _ _ p) = pathDeclaration p -pathsOfScope :: Ord scope => scope -> ScopeGraph scope term ddata -> Maybe (Map (Reference term) (Path scope term)) -pathsOfScope scope = fmap references . Map.lookup scope . unScopeGraph +pathsOfScope :: Ord scope => scope -> ScopeGraph scope ddata -> Maybe (Map Reference (Path scope)) +pathsOfScope scope = fmap references . Map.lookup scope . fst . unScopeGraph -ddataOfScope :: Ord scope => scope -> ScopeGraph scope term ddata -> Maybe (Map (Declaration term) ddata) -ddataOfScope scope = fmap declarations . Map.lookup scope . unScopeGraph +ddataOfScope :: Ord scope => scope -> ScopeGraph scope ddata -> Maybe (Map Declaration ddata) +ddataOfScope scope = fmap declarations . Map.lookup scope . fst . unScopeGraph -linksOfScope :: Ord scope => scope -> ScopeGraph scope term ddata -> Maybe (Map EdgeLabel [scope]) -linksOfScope scope = fmap edges . Map.lookup scope . unScopeGraph +linksOfScope :: Ord scope => scope -> ScopeGraph scope ddata -> Maybe (Map EdgeLabel [scope]) +linksOfScope scope = fmap edges . Map.lookup scope . fst . unScopeGraph -scopeOfRef :: (Ord term, Ord scope) => Reference term -> ScopeGraph scope term ddata -> Maybe scope -scopeOfRef ref graph = go $ Map.keys (unScopeGraph graph) +lookupScope :: Ord scope => scope -> ScopeGraph scope ddata -> Maybe (Scope scope ddata) +lookupScope scope = Map.lookup scope . fst . unScopeGraph + +currentScope :: ScopeGraph scope ddata -> scope +currentScope = snd . unScopeGraph + +declare :: Ord scope => Declaration -> ddata -> ScopeGraph scope ddata -> ScopeGraph scope ddata +declare declaration ddata graph = let scopeKey = currentScope graph + in case lookupScope scopeKey graph of + Just scope -> let newScope = scope { declarations = Map.insert declaration ddata (declarations scope) } + in graph { unScopeGraph = (Map.insert scopeKey newScope (fst $ unScopeGraph graph), scopeKey) } + Nothing -> graph + +scopeOfRef :: Ord scope => Reference -> ScopeGraph scope ddata -> Maybe scope +scopeOfRef ref graph = go . Map.keys . fst $ unScopeGraph graph where go (s : scopes') = case pathsOfScope s graph of Just pathMap -> case Map.lookup ref pathMap of - Just _ -> Just s + Just _ -> Just s Nothing -> go scopes' Nothing -> go scopes' go [] = Nothing -pathOfRef :: (Ord term, Ord scope) => Reference term -> ScopeGraph scope term ddata -> Maybe (Path scope term) +pathOfRef :: (Ord scope) => Reference -> ScopeGraph scope ddata -> Maybe (Path scope) pathOfRef ref graph = do scope <- scopeOfRef ref graph pathsMap <- pathsOfScope scope graph Map.lookup ref pathsMap -scopeOfDeclaration :: (Ord term, Ord scope) => Declaration term -> ScopeGraph scope term ddata -> Maybe scope -scopeOfDeclaration declaration graph = go $ Map.keys (unScopeGraph graph) +scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope ddata -> Maybe scope +scopeOfDeclaration declaration graph = go . Map.keys . fst $ (unScopeGraph graph) where go (s : scopes') = case ddataOfScope s graph of Just ddataMap -> case Map.lookup declaration ddataMap of - Just _ -> Just s + Just _ -> Just s Nothing -> go scopes' Nothing -> go scopes' go [] = Nothing -data Reference term = Reference Name term +newtype Reference = Reference Name deriving (Eq, Ord, Show) -data Declaration term = Declaration Name term +newtype Declaration = Declaration Name deriving (Eq, Ord, Show) data EdgeLabel = P | I @@ -94,8 +112,8 @@ data EdgeLabel = P | I data Frame scopeAddress frameAddress declaration value = Frame { scopeAddress :: scopeAddress - , links :: Map EdgeLabel (Map scopeAddress frameAddress) - , slots :: Map declaration value + , links :: Map EdgeLabel (Map scopeAddress frameAddress) + , slots :: Map declaration value } newtype Heap scopeAddress frameAddress declaration value = Heap { unHeap :: Map frameAddress (Frame scopeAddress frameAddress declaration value) } @@ -126,7 +144,7 @@ setSlot address declaration value heap = Heap $ Map.insert address (frame { slots = (Map.insert declaration value slotMap) }) (unHeap heap) Nothing -> heap -lookup :: (Ord address, Ord scope) => Heap scope address declaration value -> address -> (Path scope term) -> declaration -> Maybe scope +lookup :: (Ord address, Ord scope) => Heap scope address declaration value -> address -> Path scope -> declaration -> Maybe scope lookup heap address (DPath d) declaration = scopeLookup address heap lookup heap address (EPath label scope path) declaration = do frame <- frameLookup address heap @@ -147,7 +165,7 @@ fillFrame :: Ord address => address -> Map declaration value -> Heap scope addre fillFrame address slots heap = case frameLookup address heap of Just frame -> insertFrame address (frame { slots = slots }) heap - Nothing -> heap + Nothing -> heap deleteFrame :: Ord address => address -> Heap scope address declaration value -> Heap scope address declaration value deleteFrame address = Heap . Map.delete address . unHeap From aa403de87ab4688da428cdba7d3d7462d4ec42fe Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 11 Sep 2018 20:01:51 -0400 Subject: [PATCH 11/72] Implement adding references to declarations --- src/Control/Abstract/ScopeGraph.hs | 2 +- src/Data/Abstract/ScopeGraph.hs | 34 ++++++++++++++++++++++++++---- 2 files changed, 31 insertions(+), 5 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 3b329560f..d9cdda224 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -35,5 +35,5 @@ handleScopeEnv = \case pure () Reference ref decl -> do graph <- get - put @(ScopeGraph scope ddata) (ScopeGraph.reference reference decl graph) + put @(ScopeGraph scope ddata) (ScopeGraph.reference ref decl graph) pure () diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 48e20b4aa..dacb640ac 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -16,6 +16,7 @@ module Data.Abstract.ScopeGraph , scopeOfRef , declare , emptyGraph + , reference ) where import Data.Abstract.Live @@ -26,7 +27,7 @@ import Prelude hiding (lookup) import Prologue data Scope scopeAddress ddata = Scope { - edges :: Map EdgeLabel [scopeAddress] + edges :: Map EdgeLabel [scopeAddress] -- Maybe Map EdgeLabel [Path scope]? , references :: Map Reference (Path scopeAddress) , declarations :: Map Declaration ddata } deriving (Eq, Show, Ord) @@ -41,9 +42,9 @@ deriving instance (Eq address, Eq ddata) => Eq (ScopeGraph address ddata) deriving instance (Show address, Show ddata) => Show (ScopeGraph address ddata) deriving instance (Ord address, Ord ddata) => Ord (ScopeGraph address ddata) -data Path scopeAddress where - DPath :: Declaration -> Path scopeAddress - EPath :: EdgeLabel -> scopeAddress -> Path scopeAddress -> Path scopeAddress +data Path scope where + DPath :: Declaration -> Path scope + EPath :: EdgeLabel -> scope -> Path scope -> Path scope deriving instance Eq scope => Eq (Path scope) deriving instance Show scope => Show (Path scope) @@ -68,6 +69,9 @@ lookupScope scope = Map.lookup scope . fst . unScopeGraph currentScope :: ScopeGraph scope ddata -> scope currentScope = snd . unScopeGraph +scopeGraph :: ScopeGraph scope ddata -> Map scope (Scope scope ddata) +scopeGraph = fst . unScopeGraph + declare :: Ord scope => Declaration -> ddata -> ScopeGraph scope ddata -> ScopeGraph scope ddata declare declaration ddata graph = let scopeKey = currentScope graph in case lookupScope scopeKey graph of @@ -75,6 +79,28 @@ declare declaration ddata graph = let scopeKey = currentScope graph in graph { unScopeGraph = (Map.insert scopeKey newScope (fst $ unScopeGraph graph), scopeKey) } Nothing -> graph +reference :: Ord scope => Reference -> Declaration -> ScopeGraph scope ddata -> ScopeGraph scope ddata +reference ref declaration graph = let + currentAddress = currentScope graph + declDataOfScope address = do + dataMap <- ddataOfScope address graph + Map.lookup declaration dataMap + go currentScope address path = + case declDataOfScope address of + Just ddata -> + let newScope = currentScope { references = Map.insert ref (path (DPath declaration)) (references currentScope) } + in Just (graph { unScopeGraph = (Map.insert currentAddress newScope (scopeGraph graph), currentAddress) }) + Nothing -> let + traverseEdges edge = do + linkMap <- linksOfScope address graph + scopes <- Map.lookup edge linkMap + getFirst (flip foldMap scopes $ (First . (\nextAddress -> + go currentScope nextAddress (path . (EPath edge nextAddress))))) + in traverseEdges P <|> traverseEdges I + in case lookupScope currentAddress graph of + Just currentScope -> fromMaybe graph (go currentScope currentAddress id) + Nothing -> graph + scopeOfRef :: Ord scope => Reference -> ScopeGraph scope ddata -> Maybe scope scopeOfRef ref graph = go . Map.keys . fst $ unScopeGraph graph where From 3d480ee358cf1c34d4b780850b828fc9cc4c376b Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 10:16:52 -0400 Subject: [PATCH 12/72] brackets --- src/Data/Abstract/ScopeGraph.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index dacb640ac..86d3a13b3 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -94,8 +94,8 @@ reference ref declaration graph = let traverseEdges edge = do linkMap <- linksOfScope address graph scopes <- Map.lookup edge linkMap - getFirst (flip foldMap scopes $ (First . (\nextAddress -> - go currentScope nextAddress (path . (EPath edge nextAddress))))) + getFirst (flip foldMap scopes . First $ \nextAddress -> + go currentScope nextAddress (path . EPath edge nextAddress)) in traverseEdges P <|> traverseEdges I in case lookupScope currentAddress graph of Just currentScope -> fromMaybe graph (go currentScope currentAddress id) @@ -118,7 +118,7 @@ pathOfRef ref graph = do Map.lookup ref pathsMap scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope ddata -> Maybe scope -scopeOfDeclaration declaration graph = go . Map.keys . fst $ (unScopeGraph graph) +scopeOfDeclaration declaration graph = go . Map.keys . fst $ unScopeGraph graph where go (s : scopes') = case ddataOfScope s graph of Just ddataMap -> case Map.lookup declaration ddataMap of @@ -167,7 +167,7 @@ setSlot :: (Ord address, Ord declaration) => address -> declaration -> value -> setSlot address declaration value heap = case frameLookup address heap of Just frame -> let slotMap = slots frame in - Heap $ Map.insert address (frame { slots = (Map.insert declaration value slotMap) }) (unHeap heap) + Heap $ Map.insert address (frame { slots = Map.insert declaration value slotMap }) (unHeap heap) Nothing -> heap lookup :: (Ord address, Ord scope) => Heap scope address declaration value -> address -> Path scope -> declaration -> Maybe scope From a6f300813a2b3c0ee315fe004932aa6a768e1223 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 11:11:14 -0400 Subject: [PATCH 13/72] Allow creating scopes --- src/Control/Abstract/ScopeGraph.hs | 22 +++++++++++++++------- src/Data/Abstract/ScopeGraph.hs | 10 ++++++++-- 2 files changed, 23 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index d9cdda224..cefa984e2 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -1,28 +1,31 @@ -{-# LANGUAGE LambdaCase, TypeOperators, GADTs, KindSignatures, ScopedTypeVariables, RankNTypes #-} -module Control.Abstract.ScopeGraph where +{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} +module Control.Abstract.ScopeGraph (runScopeEnv, ScopeEnv) where -import Data.Abstract.ScopeGraph as ScopeGraph -import Control.Monad.Effect import Control.Abstract.Evaluator +import Data.Abstract.Name +import Data.Abstract.ScopeGraph as ScopeGraph +import Prologue data ScopeEnv address ddata (m :: * -> *) a where Lookup :: Reference -> ScopeEnv address ddata m (Maybe address) Declare :: Declaration -> ddata -> ScopeEnv address ddata m () Reference :: Reference -> Declaration -> ScopeEnv address ddata m () + Create :: Map EdgeLabel [Name] -> ScopeEnv Name ddata m () instance PureEffect (ScopeEnv address ddata) instance Effect (ScopeEnv address ddata) where - handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) + handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) handleState c dist (Request (Declare decl ddata) k) = Request (Declare decl ddata) (dist . (<$ c) . k) handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k) + handleState c dist (Request (Create edges) k) = Request (Create edges) (dist . (<$ c) . k) -runScopeEnv :: (Ord scope, Effects effects) +runScopeEnv :: (Ord scope, Effects effects, Member Fresh effects) => scope -> Evaluator address value (ScopeEnv scope ddata ': effects) a -> Evaluator address value effects (ScopeGraph scope ddata, a) runScopeEnv scope = runState (ScopeGraph.emptyGraph scope) . reinterpret handleScopeEnv -handleScopeEnv :: forall scope address ddata value effects a. (Ord scope) +handleScopeEnv :: forall scope address ddata value effects a. (Ord scope, Member Fresh effects) => ScopeEnv scope ddata (Eff (ScopeEnv scope ddata ': effects)) a -> Evaluator address value (State (ScopeGraph scope ddata) ': effects) a handleScopeEnv = \case @@ -37,3 +40,8 @@ handleScopeEnv = \case graph <- get put @(ScopeGraph scope ddata) (ScopeGraph.reference ref decl graph) pure () + Create edges -> do + graph <- get @(ScopeGraph scope ddata) + scope <- gensym + put (ScopeGraph.create scope edges graph) + pure () diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 86d3a13b3..cbb44f07d 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -17,6 +17,7 @@ module Data.Abstract.ScopeGraph , declare , emptyGraph , reference + , create ) where import Data.Abstract.Live @@ -94,13 +95,18 @@ reference ref declaration graph = let traverseEdges edge = do linkMap <- linksOfScope address graph scopes <- Map.lookup edge linkMap - getFirst (flip foldMap scopes . First $ \nextAddress -> - go currentScope nextAddress (path . EPath edge nextAddress)) + -- Return the first path to the declaration through the scopes. + getFirst (foldMap (First . ap (go currentScope) ((path .) . EPath edge)) scopes) in traverseEdges P <|> traverseEdges I in case lookupScope currentAddress graph of Just currentScope -> fromMaybe graph (go currentScope currentAddress id) Nothing -> graph +create :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address ddata -> ScopeGraph address ddata +create address edges graph = graph { unScopeGraph = (Map.insert address newScope (scopeGraph graph), address) } + where + newScope = Scope edges mempty mempty + scopeOfRef :: Ord scope => Reference -> ScopeGraph scope ddata -> Maybe scope scopeOfRef ref graph = go . Map.keys . fst $ unScopeGraph graph where From ba3ae715fe33d810c41e363ad99924592b4ac407 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 11:51:17 -0400 Subject: [PATCH 14/72] Store Spans in the scope graph --- src/Control/Abstract/ScopeGraph.hs | 33 ++++++++++++------------ src/Data/Abstract/ScopeGraph.hs | 41 +++++++++++++++--------------- 2 files changed, 38 insertions(+), 36 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index cefa984e2..b0e33430a 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -3,17 +3,18 @@ module Control.Abstract.ScopeGraph (runScopeEnv, ScopeEnv) where import Control.Abstract.Evaluator import Data.Abstract.Name +import Data.Span import Data.Abstract.ScopeGraph as ScopeGraph import Prologue -data ScopeEnv address ddata (m :: * -> *) a where - Lookup :: Reference -> ScopeEnv address ddata m (Maybe address) - Declare :: Declaration -> ddata -> ScopeEnv address ddata m () - Reference :: Reference -> Declaration -> ScopeEnv address ddata m () - Create :: Map EdgeLabel [Name] -> ScopeEnv Name ddata m () +data ScopeEnv address (m :: * -> *) a where + Lookup :: Reference -> ScopeEnv address m (Maybe address) + Declare :: Declaration -> Span -> ScopeEnv address m () + Reference :: Reference -> Declaration -> ScopeEnv address m () + Create :: Map EdgeLabel [Name] -> ScopeEnv Name m () -instance PureEffect (ScopeEnv address ddata) -instance Effect (ScopeEnv address ddata) where +instance PureEffect (ScopeEnv address) +instance Effect (ScopeEnv address) where handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) handleState c dist (Request (Declare decl ddata) k) = Request (Declare decl ddata) (dist . (<$ c) . k) handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k) @@ -21,27 +22,27 @@ instance Effect (ScopeEnv address ddata) where runScopeEnv :: (Ord scope, Effects effects, Member Fresh effects) => scope - -> Evaluator address value (ScopeEnv scope ddata ': effects) a - -> Evaluator address value effects (ScopeGraph scope ddata, a) + -> Evaluator address value (ScopeEnv scope ': effects) a + -> Evaluator address value effects (ScopeGraph scope, a) runScopeEnv scope = runState (ScopeGraph.emptyGraph scope) . reinterpret handleScopeEnv -handleScopeEnv :: forall scope address ddata value effects a. (Ord scope, Member Fresh effects) - => ScopeEnv scope ddata (Eff (ScopeEnv scope ddata ': effects)) a - -> Evaluator address value (State (ScopeGraph scope ddata) ': effects) a +handleScopeEnv :: forall scope address value effects a. (Ord scope, Member Fresh effects) + => ScopeEnv scope (Eff (ScopeEnv scope ': effects)) a + -> Evaluator address value (State (ScopeGraph scope) ': effects) a handleScopeEnv = \case Lookup ref -> do - graph <- get @(ScopeGraph scope ddata) + graph <- get @(ScopeGraph scope) pure (ScopeGraph.scopeOfRef ref graph) Declare decl ddata -> do graph <- get - put @(ScopeGraph scope ddata) (ScopeGraph.declare decl ddata graph) + put @(ScopeGraph scope) (ScopeGraph.declare decl ddata graph) pure () Reference ref decl -> do graph <- get - put @(ScopeGraph scope ddata) (ScopeGraph.reference ref decl graph) + put @(ScopeGraph scope) (ScopeGraph.reference ref decl graph) pure () Create edges -> do - graph <- get @(ScopeGraph scope ddata) + graph <- get @(ScopeGraph scope) scope <- gensym put (ScopeGraph.create scope edges graph) pure () diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index cbb44f07d..94e1722dd 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -24,24 +24,25 @@ import Data.Abstract.Live import Data.Abstract.Name import qualified Data.Map.Strict as Map import Data.Semigroup.Reducer +import Data.Span import Prelude hiding (lookup) import Prologue -data Scope scopeAddress ddata = Scope { +data Scope scopeAddress = Scope { edges :: Map EdgeLabel [scopeAddress] -- Maybe Map EdgeLabel [Path scope]? , references :: Map Reference (Path scopeAddress) - , declarations :: Map Declaration ddata + , declarations :: Map Declaration Span } deriving (Eq, Show, Ord) -data ScopeGraph scope ddata = ScopeGraph { unScopeGraph :: (Map scope (Scope scope ddata), scope) } +data ScopeGraph scope = ScopeGraph { unScopeGraph :: (Map scope (Scope scope), scope) } -emptyGraph :: scope -> ScopeGraph scope ddata +emptyGraph :: scope -> ScopeGraph scope emptyGraph scope = ScopeGraph (Map.singleton scope (Scope mempty mempty mempty), scope) -deriving instance (Eq address, Eq ddata) => Eq (ScopeGraph address ddata) -deriving instance (Show address, Show ddata) => Show (ScopeGraph address ddata) -deriving instance (Ord address, Ord ddata) => Ord (ScopeGraph address ddata) +deriving instance Eq address => Eq (ScopeGraph address) +deriving instance Show address => Show (ScopeGraph address) +deriving instance Ord address => Ord (ScopeGraph address) data Path scope where DPath :: Declaration -> Path scope @@ -55,32 +56,32 @@ pathDeclaration :: Path scope -> Declaration pathDeclaration (DPath d) = d pathDeclaration (EPath _ _ p) = pathDeclaration p -pathsOfScope :: Ord scope => scope -> ScopeGraph scope ddata -> Maybe (Map Reference (Path scope)) +pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference (Path scope)) pathsOfScope scope = fmap references . Map.lookup scope . fst . unScopeGraph -ddataOfScope :: Ord scope => scope -> ScopeGraph scope ddata -> Maybe (Map Declaration ddata) +ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Declaration Span) ddataOfScope scope = fmap declarations . Map.lookup scope . fst . unScopeGraph -linksOfScope :: Ord scope => scope -> ScopeGraph scope ddata -> Maybe (Map EdgeLabel [scope]) +linksOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map EdgeLabel [scope]) linksOfScope scope = fmap edges . Map.lookup scope . fst . unScopeGraph -lookupScope :: Ord scope => scope -> ScopeGraph scope ddata -> Maybe (Scope scope ddata) +lookupScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Scope scope) lookupScope scope = Map.lookup scope . fst . unScopeGraph -currentScope :: ScopeGraph scope ddata -> scope +currentScope :: ScopeGraph scope -> scope currentScope = snd . unScopeGraph -scopeGraph :: ScopeGraph scope ddata -> Map scope (Scope scope ddata) +scopeGraph :: ScopeGraph scope -> Map scope (Scope scope) scopeGraph = fst . unScopeGraph -declare :: Ord scope => Declaration -> ddata -> ScopeGraph scope ddata -> ScopeGraph scope ddata +declare :: Ord scope => Declaration -> Span -> ScopeGraph scope -> ScopeGraph scope declare declaration ddata graph = let scopeKey = currentScope graph in case lookupScope scopeKey graph of Just scope -> let newScope = scope { declarations = Map.insert declaration ddata (declarations scope) } in graph { unScopeGraph = (Map.insert scopeKey newScope (fst $ unScopeGraph graph), scopeKey) } Nothing -> graph -reference :: Ord scope => Reference -> Declaration -> ScopeGraph scope ddata -> ScopeGraph scope ddata +reference :: Ord scope => Reference -> Declaration -> ScopeGraph scope -> ScopeGraph scope reference ref declaration graph = let currentAddress = currentScope graph declDataOfScope address = do @@ -100,14 +101,14 @@ reference ref declaration graph = let in traverseEdges P <|> traverseEdges I in case lookupScope currentAddress graph of Just currentScope -> fromMaybe graph (go currentScope currentAddress id) - Nothing -> graph + Nothing -> graph -create :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address ddata -> ScopeGraph address ddata +create :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address create address edges graph = graph { unScopeGraph = (Map.insert address newScope (scopeGraph graph), address) } where newScope = Scope edges mempty mempty -scopeOfRef :: Ord scope => Reference -> ScopeGraph scope ddata -> Maybe scope +scopeOfRef :: Ord scope => Reference -> ScopeGraph scope -> Maybe scope scopeOfRef ref graph = go . Map.keys . fst $ unScopeGraph graph where go (s : scopes') = case pathsOfScope s graph of @@ -117,13 +118,13 @@ scopeOfRef ref graph = go . Map.keys . fst $ unScopeGraph graph Nothing -> go scopes' go [] = Nothing -pathOfRef :: (Ord scope) => Reference -> ScopeGraph scope ddata -> Maybe (Path scope) +pathOfRef :: (Ord scope) => Reference -> ScopeGraph scope -> Maybe (Path scope) pathOfRef ref graph = do scope <- scopeOfRef ref graph pathsMap <- pathsOfScope scope graph Map.lookup ref pathsMap -scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope ddata -> Maybe scope +scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope scopeOfDeclaration declaration graph = go . Map.keys . fst $ unScopeGraph graph where go (s : scopes') = case ddataOfScope s graph of From 0cdb6f970721bfaac5ee624527776b831af21a15 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 12:48:58 -0400 Subject: [PATCH 15/72] Add scope graph to ModuleResult --- src/Control/Abstract/Modules.hs | 5 ++-- src/Control/Abstract/ScopeGraph.hs | 27 +++++++++++--------- src/Data/Abstract/Evaluatable.hs | 6 ++++- src/Language/Go/Syntax.hs | 4 +-- src/Language/PHP/Syntax.hs | 2 +- src/Language/Python/Syntax.hs | 6 ++--- src/Language/Ruby/Syntax.hs | 6 ++--- src/Language/TypeScript/Resolution.hs | 2 +- src/Language/TypeScript/Syntax/TypeScript.hs | 4 +-- src/Semantic/Graph.hs | 2 +- 10 files changed, 36 insertions(+), 28 deletions(-) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index c5f69d81f..a1f00316f 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -30,8 +30,9 @@ import qualified Data.Set as Set import Data.Span import Prologue import System.FilePath.Posix (takeDirectory) +import Data.Abstract.ScopeGraph -type ModuleResult address = (Bindings address, address) +type ModuleResult address = (ScopeGraph address, (Bindings address, address)) -- | Retrieve an evaluated module, if any. @Nothing@ means we’ve never tried to load it, and @Just (env, value)@ indicates the result of a completed load. lookupModule :: Member (Modules address) effects => ModulePath -> Evaluator address value effects (Maybe (ModuleResult address)) @@ -94,7 +95,7 @@ askModuleTable = ask newtype Merging address = Merging { runMerging :: ModuleResult address } instance Semigroup (Merging address) where - Merging (binds1, _) <> Merging (binds2, addr) = Merging (binds1 <> binds2, addr) + Merging (_, (binds1, _)) <> Merging (graph2, (binds2, addr)) = Merging (graph2, (binds1 <> binds2, addr)) -- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name. diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index b0e33430a..a86595266 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -2,6 +2,7 @@ module Control.Abstract.ScopeGraph (runScopeEnv, ScopeEnv) where import Control.Abstract.Evaluator +import Control.Abstract.Heap import Data.Abstract.Name import Data.Span import Data.Abstract.ScopeGraph as ScopeGraph @@ -20,29 +21,31 @@ instance Effect (ScopeEnv address) where handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k) handleState c dist (Request (Create edges) k) = Request (Create edges) (dist . (<$ c) . k) -runScopeEnv :: (Ord scope, Effects effects, Member Fresh effects) - => scope - -> Evaluator address value (ScopeEnv scope ': effects) a - -> Evaluator address value effects (ScopeGraph scope, a) -runScopeEnv scope = runState (ScopeGraph.emptyGraph scope) . reinterpret handleScopeEnv +runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects) + => Evaluator address value (ScopeEnv address ': effects) a + -> Evaluator address value effects (ScopeGraph address, a) +runScopeEnv evaluator = do + name <- gensym + address <- alloc name + runState (ScopeGraph.emptyGraph address) (reinterpret handleScopeEnv evaluator) -handleScopeEnv :: forall scope address value effects a. (Ord scope, Member Fresh effects) - => ScopeEnv scope (Eff (ScopeEnv scope ': effects)) a - -> Evaluator address value (State (ScopeGraph scope) ': effects) a +handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh effects) + => ScopeEnv address (Eff (ScopeEnv address ': effects)) a + -> Evaluator address value (State (ScopeGraph address) ': effects) a handleScopeEnv = \case Lookup ref -> do - graph <- get @(ScopeGraph scope) + graph <- get @(ScopeGraph address) pure (ScopeGraph.scopeOfRef ref graph) Declare decl ddata -> do graph <- get - put @(ScopeGraph scope) (ScopeGraph.declare decl ddata graph) + put @(ScopeGraph address) (ScopeGraph.declare decl ddata graph) pure () Reference ref decl -> do graph <- get - put @(ScopeGraph scope) (ScopeGraph.reference ref decl graph) + put @(ScopeGraph address) (ScopeGraph.reference ref decl graph) pure () Create edges -> do - graph <- get @(ScopeGraph scope) + graph <- get @(ScopeGraph address) scope <- gensym put (ScopeGraph.create scope edges graph) pure () diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 88d842edf..e96c25ad7 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -28,6 +28,7 @@ import Control.Abstract.Evaluator as X hiding (LoopControl(..), Return(..), catc import Control.Abstract.Heap as X hiding (runAddressError, runAddressErrorWith) import Control.Abstract.Modules as X (Modules, ModuleResult, ResolutionError(..), load, lookupModule, listModulesInDir, require, resolve, throwResolutionError) import Control.Abstract.Value as X hiding (Boolean(..), Function(..)) +import Control.Abstract.ScopeGraph import Data.Abstract.Declarations as X import Data.Abstract.Environment as X import Data.Abstract.BaseError as X @@ -53,6 +54,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member (Allocator address) effects , Member (Boolean value) effects , Member (Deref value) effects + , Member (ScopeEnv address) effects , Member (Env address) effects , Member (Exc (LoopControl address)) effects , Member (Exc (Return address)) effects @@ -82,6 +84,7 @@ type ModuleEffects address value rest = Exc (LoopControl address) ': Exc (Return address) ': Env address + ': ScopeEnv address ': Deref value ': Allocator address ': Reader ModuleInfo @@ -124,7 +127,7 @@ evaluate :: ( AbstractValue address value valueEffects -> [Module term] -> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address)))) evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do - (preludeBinds, _) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack . runValue $ do + (scopeGraph, (preludeBinds, _)) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack . runValue $ do definePrelude lang box unit foldr (run preludeBinds) ask modules @@ -143,6 +146,7 @@ evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do runInModule preludeBinds info = runReader info . runAllocDeref + . runScopeEnv . runEnv (EvalContext Nothing (X.push (newEnv preludeBinds))) . runReturn . runLoopControl diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 5baf87579..d8adfe144 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -69,7 +69,7 @@ instance Evaluatable Import where paths <- resolveGoImport importPath for_ paths $ \path -> do traceResolve (unPath importPath) path - importedEnv <- fst <$> require path + importedEnv <- fst . snd <$> require path bindAll importedEnv rvalBox unit @@ -91,7 +91,7 @@ instance Evaluatable QualifiedImport where void . letrec' alias $ \addr -> do makeNamespace alias addr Nothing . for_ paths $ \p -> do traceResolve (unPath importPath) p - importedEnv <- fst <$> require p + importedEnv <- fst . snd <$> require p bindAll importedEnv rvalBox unit diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 9cf201ef7..72d44f122 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -70,7 +70,7 @@ include pathTerm f = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name traceResolve name path - (importedEnv, v) <- f path + (_, (importedEnv, v)) <- f path bindAll importedEnv pure (Rval v) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 575531f27..4e4d668b8 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -145,7 +145,7 @@ instance Evaluatable Import where -- Last module path is the one we want to import let path = NonEmpty.last modulePaths - importedBinds <- fst <$> require path + importedBinds <- fst . snd <$> require path bindAll (select importedBinds) rvalBox unit where @@ -165,7 +165,7 @@ evalQualifiedImport :: ( AbstractValue address value effects ) => Name -> ModulePath -> Evaluator address value effects value evalQualifiedImport name path = letrec' name $ \addr -> do - unit <$ makeNamespace name addr Nothing (bindAll . fst =<< require path) + unit <$ makeNamespace name addr Nothing (bindAll . fst . snd =<< require path) newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty FilePath } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Named1, Ord, Show, ToJSONFields1, Traversable) @@ -218,7 +218,7 @@ instance Evaluatable QualifiedAliasedImport where alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm)) rvalBox =<< letrec' alias (\addr -> do let path = NonEmpty.last modulePaths - unit <$ makeNamespace alias addr Nothing (void (bindAll . fst =<< require path))) + unit <$ makeNamespace alias addr Nothing (void (bindAll . fst . snd =<< require path))) -- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell) data Ellipsis a = Ellipsis diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 6a7a9a840..209efa628 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -98,8 +98,8 @@ doRequire :: ( Member (Boolean value) effects doRequire path = do result <- lookupModule path case result of - Nothing -> (,) . fst <$> load path <*> boolean True - Just (env, _) -> (env,) <$> boolean False + Nothing -> (,) . fst . snd <$> load path <*> boolean True + Just (_, (env, _)) -> (env,) <$> boolean False data Load a = Load { loadPath :: a, loadWrap :: Maybe a } @@ -132,7 +132,7 @@ doLoad :: ( Member (Boolean value) effects doLoad path shouldWrap = do path' <- resolveRubyPath path traceResolve path path' - importedEnv <- fst <$> load path' + importedEnv <- fst . snd <$> load path' unless shouldWrap $ bindAll importedEnv boolean Prelude.True -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load diff --git a/src/Language/TypeScript/Resolution.hs b/src/Language/TypeScript/Resolution.hs index 1d44d6c84..543b350e2 100644 --- a/src/Language/TypeScript/Resolution.hs +++ b/src/Language/TypeScript/Resolution.hs @@ -175,4 +175,4 @@ evalRequire :: ( AbstractValue address value effects -> Name -> Evaluator address value effects value evalRequire modulePath alias = letrec' alias $ \addr -> - unit <$ makeNamespace alias addr Nothing (bindAll . fst =<< require modulePath) + unit <$ makeNamespace alias addr Nothing (bindAll . fst . snd =<< require modulePath) diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index 18383dc59..92c6c14f2 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -25,7 +25,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where eval (Import symbols importPath) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedBinds <- fst <$> require modulePath + importedBinds <- fst . snd <$> require modulePath bindAll (renamed importedBinds) rvalBox unit where @@ -92,7 +92,7 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedExportFrom where eval (QualifiedExportFrom importPath exportSymbols) = do modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - importedBinds <- fst <$> require modulePath + importedBinds <- fst . snd <$> require modulePath -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \Alias{..} -> do let address = Env.lookup aliasValue importedBinds diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index f4b588054..a1d91afee 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -347,7 +347,7 @@ resumingLoadError :: ( Applicative (m address value effects) => m address value (Resumable (BaseError (LoadError address)) ': effects) a -> m address value effects a resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of - ModuleNotFoundError _ -> pure (lowerBound, hole)) + ModuleNotFoundError _ -> pure (undefined, (lowerBound, hole))) resumingEvalError :: ( Applicative (m effects) , Effectful m From daa64439f3232da970e5592d98f5d975796d8a5c Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 16:19:26 -0400 Subject: [PATCH 16/72] simplify --- src/Control/Abstract/ScopeGraph.hs | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index a86595266..fc58756d6 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -33,19 +33,9 @@ handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh eff => ScopeEnv address (Eff (ScopeEnv address ': effects)) a -> Evaluator address value (State (ScopeGraph address) ': effects) a handleScopeEnv = \case - Lookup ref -> do - graph <- get @(ScopeGraph address) - pure (ScopeGraph.scopeOfRef ref graph) - Declare decl ddata -> do - graph <- get - put @(ScopeGraph address) (ScopeGraph.declare decl ddata graph) - pure () - Reference ref decl -> do - graph <- get - put @(ScopeGraph address) (ScopeGraph.reference ref decl graph) - pure () + Lookup ref -> ScopeGraph.scopeOfRef ref <$> get + Declare decl ddata -> modify @(ScopeGraph address) (ScopeGraph.declare decl ddata) + Reference ref decl -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) Create edges -> do - graph <- get @(ScopeGraph address) scope <- gensym - put (ScopeGraph.create scope edges graph) - pure () + modify @(ScopeGraph address) (ScopeGraph.create scope edges) From d5926dfabfa2a78b143a82d3f978ec7bf9c601c2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 16:22:23 -0400 Subject: [PATCH 17/72] don't specialize to Name --- src/Control/Abstract/ScopeGraph.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index fc58756d6..406494ce1 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -12,7 +12,7 @@ data ScopeEnv address (m :: * -> *) a where Lookup :: Reference -> ScopeEnv address m (Maybe address) Declare :: Declaration -> Span -> ScopeEnv address m () Reference :: Reference -> Declaration -> ScopeEnv address m () - Create :: Map EdgeLabel [Name] -> ScopeEnv Name m () + Create :: Map EdgeLabel [address] -> ScopeEnv address m () instance PureEffect (ScopeEnv address) instance Effect (ScopeEnv address) where @@ -29,7 +29,7 @@ runScopeEnv evaluator = do address <- alloc name runState (ScopeGraph.emptyGraph address) (reinterpret handleScopeEnv evaluator) -handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh effects) +handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects) => ScopeEnv address (Eff (ScopeEnv address ': effects)) a -> Evaluator address value (State (ScopeGraph address) ': effects) a handleScopeEnv = \case @@ -37,5 +37,6 @@ handleScopeEnv = \case Declare decl ddata -> modify @(ScopeGraph address) (ScopeGraph.declare decl ddata) Reference ref decl -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) Create edges -> do - scope <- gensym - modify @(ScopeGraph address) (ScopeGraph.create scope edges) + name <- gensym + address <- alloc name + modify @(ScopeGraph address) (ScopeGraph.create address edges) From 95ac3655cb6ab84a642dd10c9b91a8878caeaa24 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 16:28:39 -0400 Subject: [PATCH 18/72] add helper functions --- src/Control/Abstract/ScopeGraph.hs | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 406494ce1..aec0b4e79 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -1,12 +1,14 @@ {-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} -module Control.Abstract.ScopeGraph (runScopeEnv, ScopeEnv) where +module Control.Abstract.ScopeGraph (runScopeEnv, ScopeEnv, lookup, declare, reference, create) where import Control.Abstract.Evaluator import Control.Abstract.Heap import Data.Abstract.Name import Data.Span -import Data.Abstract.ScopeGraph as ScopeGraph +import Data.Abstract.ScopeGraph (Declaration, Reference, EdgeLabel, ScopeGraph) +import qualified Data.Abstract.ScopeGraph as ScopeGraph import Prologue +import Prelude hiding (lookup) data ScopeEnv address (m :: * -> *) a where Lookup :: Reference -> ScopeEnv address m (Maybe address) @@ -14,6 +16,18 @@ data ScopeEnv address (m :: * -> *) a where Reference :: Reference -> Declaration -> ScopeEnv address m () Create :: Map EdgeLabel [address] -> ScopeEnv address m () +lookup :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator address value effects (Maybe address) +lookup = send . Lookup @address + +declare :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Evaluator address value effects () +declare = (send .) . Declare @address + +reference :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator address value effects () +reference = (send .) . Reference @address + +create :: forall address value effects. Member (ScopeEnv address) effects => Map EdgeLabel [address] -> Evaluator address value effects () +create = send . Create @address + instance PureEffect (ScopeEnv address) instance Effect (ScopeEnv address) where handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) From d6e98cc08a6d29c658c86cecb81b5b0523dee1f0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 17:01:12 -0400 Subject: [PATCH 19/72] Add class declarations to the scope graph --- src/Control/Abstract/ScopeGraph.hs | 8 ++++---- src/Data/Abstract/ScopeGraph.hs | 2 +- src/Data/Syntax/Declaration.hs | 7 +++++++ src/Language/TypeScript/Syntax/TypeScript.hs | 5 ++++- 4 files changed, 16 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index aec0b4e79..5be00ccd1 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -1,11 +1,11 @@ {-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} -module Control.Abstract.ScopeGraph (runScopeEnv, ScopeEnv, lookup, declare, reference, create) where +module Control.Abstract.ScopeGraph (runScopeEnv, ScopeEnv, lookup, declare, reference, newScope, Declaration(..)) where import Control.Abstract.Evaluator import Control.Abstract.Heap import Data.Abstract.Name import Data.Span -import Data.Abstract.ScopeGraph (Declaration, Reference, EdgeLabel, ScopeGraph) +import Data.Abstract.ScopeGraph (Declaration(..), Reference, EdgeLabel, ScopeGraph) import qualified Data.Abstract.ScopeGraph as ScopeGraph import Prologue import Prelude hiding (lookup) @@ -25,8 +25,8 @@ declare = (send .) . Declare @address reference :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator address value effects () reference = (send .) . Reference @address -create :: forall address value effects. Member (ScopeEnv address) effects => Map EdgeLabel [address] -> Evaluator address value effects () -create = send . Create @address +newScope :: forall address value effects. Member (ScopeEnv address) effects => Map EdgeLabel [address] -> Evaluator address value effects () +newScope = send . Create @address instance PureEffect (ScopeEnv address) instance Effect (ScopeEnv address) where diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 94e1722dd..c3ea9df77 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -3,7 +3,7 @@ module Data.Abstract.ScopeGraph ( ScopeGraph(..) , Path , Reference - , Declaration + , Declaration(..) , EdgeLabel , Heap , frameLookup diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index c41a14f94..5488b3af6 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -4,6 +4,7 @@ module Data.Syntax.Declaration where import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable +import Control.Abstract.ScopeGraph import Data.JSON.Fields import qualified Data.Set as Set import Diffing.Algorithm @@ -187,6 +188,12 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Class where eval Class{..} = do name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier)) + span <- ask @Span + -- Add the class to the current scope. + declare (Declaration name) span + -- Start a new scope. + newScope mempty + supers <- traverse subtermAddress classSuperclasses (_, addr) <- letrec name $ do void $ subtermValue classBody diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index 92c6c14f2..54ba83cb7 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -274,7 +274,10 @@ instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec instance Evaluatable PredefinedType newtype TypeIdentifier a = TypeIdentifier { contents :: T.Text } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + +instance Declarations1 TypeIdentifier where + liftDeclaredName _ (TypeIdentifier identifier) = Just (name identifier) instance Eq1 TypeIdentifier where liftEq = genericLiftEq instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare From 360a9b031785b71e5c8d7f26c8f5a1b220bac8fd Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 19:56:02 -0400 Subject: [PATCH 20/72] Store the Span of last evaluated child term in a State So we can declare a child term's range in the scope graph when a declaration occurs. Co-Authored-By: Rick Winfrey --- src/Control/Abstract/Context.hs | 4 +++ src/Control/Abstract/ScopeGraph.hs | 35 +++++++++++++++----- src/Data/Abstract/Evaluatable.hs | 2 ++ src/Data/Abstract/ScopeGraph.hs | 5 +-- src/Data/Syntax/Declaration.hs | 27 ++++++++++++--- src/Data/Syntax/Statement.hs | 5 ++- src/Language/TypeScript/Syntax/TypeScript.hs | 2 ++ src/Semantic/Graph.hs | 9 ++++- src/Semantic/REPL.hs | 1 + src/Semantic/Util.hs | 9 +++-- 10 files changed, 79 insertions(+), 20 deletions(-) diff --git a/src/Control/Abstract/Context.hs b/src/Control/Abstract/Context.hs index bf1184697..1581dec06 100644 --- a/src/Control/Abstract/Context.hs +++ b/src/Control/Abstract/Context.hs @@ -8,11 +8,13 @@ module Control.Abstract.Context , Span , currentSpan , withCurrentSpan +, modifyChildSpan , withCurrentCallStack ) where import Control.Monad.Effect import Control.Monad.Effect.Reader +import Control.Monad.Effect.State import Data.Abstract.Module import Data.Abstract.Package import Data.Span @@ -43,6 +45,8 @@ currentSpan = ask withCurrentSpan :: (Effectful m, Member (Reader Span) effects) => Span -> m effects a -> m effects a withCurrentSpan = local . const +modifyChildSpan :: (Effectful m, Member (State Span) effects) => Span -> m effects a -> m effects a +modifyChildSpan span m = raiseEff (lowerEff m >>= (\a -> modify' (const span) >> pure a)) -- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'. withCurrentSrcLoc :: (Effectful m, Member (Reader ModuleInfo) effects, Member (Reader Span) effects) => SrcLoc -> m effects a -> m effects a diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 5be00ccd1..571d3b2c1 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -1,20 +1,32 @@ {-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, ScopedTypeVariables, TypeOperators #-} -module Control.Abstract.ScopeGraph (runScopeEnv, ScopeEnv, lookup, declare, reference, newScope, Declaration(..)) where +module Control.Abstract.ScopeGraph + ( runScopeEnv + , ScopeEnv + , lookup + , declare + , reference + , newScope + , Declaration(..) + , Reference(..) + , EdgeLabel(..) + , currentScope + ) where -import Control.Abstract.Evaluator -import Control.Abstract.Heap -import Data.Abstract.Name -import Data.Span -import Data.Abstract.ScopeGraph (Declaration(..), Reference, EdgeLabel, ScopeGraph) +import Control.Abstract.Evaluator +import Control.Abstract.Heap +import Data.Abstract.Name +import Data.Abstract.ScopeGraph (Declaration (..), EdgeLabel, Reference, ScopeGraph) import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Prologue -import Prelude hiding (lookup) +import Data.Span +import Prelude hiding (lookup) +import Prologue data ScopeEnv address (m :: * -> *) a where Lookup :: Reference -> ScopeEnv address m (Maybe address) Declare :: Declaration -> Span -> ScopeEnv address m () Reference :: Reference -> Declaration -> ScopeEnv address m () Create :: Map EdgeLabel [address] -> ScopeEnv address m () + CurrentScope :: ScopeEnv address m address lookup :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator address value effects (Maybe address) lookup = send . Lookup @address @@ -28,12 +40,16 @@ reference = (send .) . Reference @address newScope :: forall address value effects. Member (ScopeEnv address) effects => Map EdgeLabel [address] -> Evaluator address value effects () newScope = send . Create @address +currentScope :: forall address value effects. Member (ScopeEnv address) effects => Evaluator address value effects address +currentScope = send CurrentScope + instance PureEffect (ScopeEnv address) instance Effect (ScopeEnv address) where handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) handleState c dist (Request (Declare decl ddata) k) = Request (Declare decl ddata) (dist . (<$ c) . k) handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k) - handleState c dist (Request (Create edges) k) = Request (Create edges) (dist . (<$ c) . k) + handleState c dist (Request (Create edges) k) = Request (Create edges) (dist . (<$ c) . k) + handleState c dist (Request CurrentScope k) = Request CurrentScope (dist . (<$ c) . k) runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects) => Evaluator address value (ScopeEnv address ': effects) a @@ -54,3 +70,4 @@ handleScopeEnv = \case name <- gensym address <- alloc name modify @(ScopeGraph address) (ScopeGraph.create address edges) + CurrentScope -> ScopeGraph.currentScope <$> get diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index e96c25ad7..d9c632703 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -64,6 +64,7 @@ class (Show1 constr, Foldable constr) => Evaluatable constr where , Member (Reader ModuleInfo) effects , Member (Reader PackageInfo) effects , Member (Reader Span) effects + , Member (State Span) effects , Member (Resumable (BaseError (AddressError address value))) effects , Member (Resumable (BaseError (EnvironmentError address))) effects , Member (Resumable (BaseError (UnspecializedError value))) effects @@ -107,6 +108,7 @@ evaluate :: ( AbstractValue address value valueEffects , Member (Reader (ModuleTable (NonEmpty (Module (ModuleResult address))))) effects , Member (Reader PackageInfo) effects , Member (Reader Span) effects + , Member (State Span) effects , Member (Resumable (BaseError (AddressError address value))) effects , Member (Resumable (BaseError (EnvironmentError address))) effects , Member (Resumable (BaseError EvalError)) effects diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index c3ea9df77..8a034ff89 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -2,9 +2,9 @@ module Data.Abstract.ScopeGraph ( ScopeGraph(..) , Path - , Reference + , Reference(..) , Declaration(..) - , EdgeLabel + , EdgeLabel(..) , Heap , frameLookup , scopeLookup @@ -18,6 +18,7 @@ module Data.Abstract.ScopeGraph , emptyGraph , reference , create + , currentScope ) where import Data.Abstract.Live diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 5488b3af6..1f7948236 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, TupleSections #-} {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Declaration where @@ -10,6 +10,7 @@ import qualified Data.Set as Set import Diffing.Algorithm import Prologue import Proto3.Suite.Class +import qualified Data.Map.Strict as Map import Reprinting.Tokenize data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a } @@ -126,7 +127,18 @@ instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec instance Evaluatable VariableDeclaration where eval (VariableDeclaration []) = rvalBox unit - eval (VariableDeclaration decs) = rvalBox =<< tuple =<< traverse subtermAddress decs + eval (VariableDeclaration decs) = do + addresses <- for decs $ \declaration -> do + name <- maybeM (throwEvalError NoNameError) (declaredName (subterm declaration)) + (span, valueRef) <- do + ref <- subtermRef declaration -- (Assignment [Empty] Identifier Val) + subtermSpan <- get @Span + pure (subtermSpan, ref) + + declare (Declaration name) span + + address valueRef + rvalBox =<< tuple addresses instance Declarations a => Declarations (VariableDeclaration a) where declaredName (VariableDeclaration vars) = case vars of @@ -159,7 +171,13 @@ instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for PublicFieldDefinition -instance Evaluatable PublicFieldDefinition +instance Evaluatable PublicFieldDefinition where + eval PublicFieldDefinition{..} = do + span <- ask @Span + propertyName <- maybeM (throwEvalError NoNameError) (declaredName (subterm publicFieldPropertyName)) + declare (Declaration propertyName) span + rvalBox unit + data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a } @@ -192,7 +210,8 @@ instance Evaluatable Class where -- Add the class to the current scope. declare (Declaration name) span -- Start a new scope. - newScope mempty + currentScope' <- currentScope + newScope (Map.singleton P [ currentScope' ]) supers <- traverse subtermAddress classSuperclasses (_, addr) <- letrec name $ do diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index d53828879..611ca4e5a 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -121,7 +121,10 @@ instance Evaluatable Let where -- | Assignment to a variable or other lvalue. data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + +instance Declarations1 Assignment where + liftDeclaredName declaredName Assignment{..} = declaredName assignmentTarget instance Eq1 Assignment where liftEq = genericLiftEq instance Ord1 Assignment where liftCompare = genericLiftCompare diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index 54ba83cb7..827d77aab 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -10,6 +10,7 @@ import Proto3.Suite import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable +import Control.Abstract.ScopeGraph import Data.JSON.Fields import Diffing.Algorithm import Language.TypeScript.Resolution @@ -271,6 +272,7 @@ newtype PredefinedType a = PredefinedType { predefinedType :: T.Text } instance Eq1 PredefinedType where liftEq = genericLiftEq instance Ord1 PredefinedType where liftCompare = genericLiftCompare instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec +-- TODO: Implement Eval instance for PredefinedType instance Evaluatable PredefinedType newtype TypeIdentifier a = TypeIdentifier { contents :: T.Text } diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index a1d91afee..9e89f3116 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -122,6 +122,7 @@ runCallGraph lang includePackages modules package = do . resumingAddressError . runReader (packageInfo package) . runReader (lowerBound @Span) + . runState (lowerBound @Span) . runReader (lowerBound @Vertex) . providingLiveSet . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) (Located Monovariant))))))) @@ -192,6 +193,7 @@ runImportGraph lang (package :: Package term) f = . runModules (ModuleTable.modulePaths (packageModules package)) . runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _)) . runReader (packageInfo package) + . runState lowerBound . runReader lowerBound runAddressEffects = Hole.runAllocator Precise.handleAllocator @@ -200,6 +202,7 @@ runImportGraph lang (package :: Package term) f = type ConcreteEffects address rest = Reader Span + ': State Span ': Reader PackageInfo ': Modules address ': Reader (ModuleTable (NonEmpty (Module (ModuleResult address)))) @@ -273,6 +276,7 @@ parsePythonPackage parser project = do . runModules lowerBound . runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ConcreteEff (Hole (Maybe Name) Precise) _)) . runReader (PackageInfo (name "setup") lowerBound) + . runState lowerBound . runReader lowerBound runAddressEffects = Hole.runAllocator Precise.handleAllocator @@ -322,10 +326,13 @@ parseModule proj parser file = do withTermSpans :: ( HasField fields Span , Member (Reader Span) effects + , Member (State Span) effects -- last evaluated child's span ) => SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a) -> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a) -withTermSpans recur term = withCurrentSpan (getField (termFAnnotation term)) (recur term) +withTermSpans recur term = let + updatedSpanAlg = withCurrentSpan (getField (termFAnnotation term)) (recur term) + in modifyChildSpan (getField (termFAnnotation term)) updatedSpanAlg resumingResolutionError :: ( Applicative (m effects) , Effectful m diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 1f3e6a6fa..7d551b611 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -103,6 +103,7 @@ repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runD . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise))))) . raiseHandler (runModules (ModuleTable.modulePaths (packageModules (snd <$> package)))) . runReader (packageInfo package) + . runState (lowerBound @Span) . runReader (lowerBound @Span) $ evaluate proxy id (withTermSpans . step (fmap (\ (x:|_) -> moduleBody x) <$> ModuleTable.toPairs (packageModules (fst <$> package)))) (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 39e186616..e1e6459e9 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -106,8 +106,9 @@ evaluateProject' (TaskConfig config logger statter) proxy parser paths = either (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise))))) (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) (runReader (packageInfo package) + (runState (lowerBound @Span) (runReader (lowerBound @Span) - (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules)))))) + (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules))))))) evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions $ do project <- readProject Nothing path lang [] @@ -118,8 +119,9 @@ evaluatePythonProjects proxy parser lang path = runTaskWithOptions debugOptions (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise))))) (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) (runReader (packageInfo package) + (runState (lowerBound @Span) (runReader (lowerBound @Span) - (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules)))))) + (evaluate proxy id withTermSpans (Precise.runAllocator . Precise.runDeref) (Concrete.runBoolean . Concrete.runFunction coerce coerce) modules))))))) evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ do @@ -127,10 +129,11 @@ evaluateProjectWithCaching proxy parser path = runTaskWithOptions debugOptions $ package <- fmap (quieterm . snd) <$> parsePackage parser project modules <- topologicalSort <$> runImportGraphToModules proxy package pure (runReader (packageInfo package) + (runState (lowerBound @Span) (runReader (lowerBound @Span) (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Monovariant))))) (raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) - (evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (Type.runBoolean . Type.runFunction) modules))))) + (evaluate proxy id withTermSpans (Monovariant.runAllocator . Monovariant.runDeref) (Type.runBoolean . Type.runFunction) modules)))))) parseFile :: Parser term -> FilePath -> IO term From 82db9f805ef8507bf7a45caab1a7fa4670a73c87 Mon Sep 17 00:00:00 2001 From: joshvera Date: Wed, 12 Sep 2018 20:45:38 -0400 Subject: [PATCH 21/72] Emit Statements syntaxes for statementBlock in TypeScript Co-Authored-By: Rick Winfrey --- src/Language/TypeScript/Assignment.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index 2b40e195b..177d72fd3 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -620,7 +620,7 @@ constructorTy :: Assignment Term constructorTy = makeTerm <$> symbol ConstructorType <*> children (TypeScript.Syntax.Constructor <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty) statementBlock :: Assignment Term -statementBlock = makeTerm <$> symbol StatementBlock <*> children (manyTerm statement) +statementBlock = makeTerm <$> symbol StatementBlock <*> children (Statement.Statements <$> manyTerm statement) classBodyStatements :: Assignment Term classBodyStatements = makeTerm'' <$> symbol ClassBody <*> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term (methodDefinition <|> publicFieldDefinition <|> methodSignature <|> indexSignature <|> abstractMethodSignature))) <*> many comment)) From f902cac04f67400c02089e66c575eea89befcd14 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 13 Sep 2018 17:41:45 -0400 Subject: [PATCH 22/72] Use an empty graph when resuming a load error --- src/Semantic/Graph.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 9e89f3116..057accc7e 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -40,6 +40,7 @@ import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package +import qualified Data.Abstract.ScopeGraph as ScopeGraph import Data.Abstract.Value.Abstract as Abstract import Data.Abstract.Value.Concrete as Concrete (Value, ValueError (..), runBoolean, runFunction, runValueErrorWith) @@ -354,7 +355,7 @@ resumingLoadError :: ( Applicative (m address value effects) => m address value (Resumable (BaseError (LoadError address)) ': effects) a -> m address value effects a resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of - ModuleNotFoundError _ -> pure (undefined, (lowerBound, hole))) + ModuleNotFoundError _ -> pure (ScopeGraph.emptyGraph, (lowerBound, hole))) resumingEvalError :: ( Applicative (m effects) , Effectful m From cc994b0af971a3c53651beb8c4acfb7147d0f511 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 13 Sep 2018 17:41:58 -0400 Subject: [PATCH 23/72] Make currentScope optional so we can have empty graphs --- src/Data/Abstract/ScopeGraph.hs | 95 +++++++++++++++------------------ 1 file changed, 43 insertions(+), 52 deletions(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 8a034ff89..bc19f02bb 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -18,7 +18,6 @@ module Data.Abstract.ScopeGraph , emptyGraph , reference , create - , currentScope ) where import Data.Abstract.Live @@ -36,10 +35,10 @@ data Scope scopeAddress = Scope { } deriving (Eq, Show, Ord) -data ScopeGraph scope = ScopeGraph { unScopeGraph :: (Map scope (Scope scope), scope) } +data ScopeGraph scope = ScopeGraph { graph :: Map scope (Scope scope), currentScope :: Maybe scope } -emptyGraph :: scope -> ScopeGraph scope -emptyGraph scope = ScopeGraph (Map.singleton scope (Scope mempty mempty mempty), scope) +emptyGraph :: Ord scope => ScopeGraph scope +emptyGraph = ScopeGraph mempty Nothing deriving instance Eq address => Eq (ScopeGraph address) deriving instance Show address => Show (ScopeGraph address) @@ -58,65 +57,58 @@ pathDeclaration (DPath d) = d pathDeclaration (EPath _ _ p) = pathDeclaration p pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference (Path scope)) -pathsOfScope scope = fmap references . Map.lookup scope . fst . unScopeGraph +pathsOfScope scope = fmap references . Map.lookup scope . graph ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Declaration Span) -ddataOfScope scope = fmap declarations . Map.lookup scope . fst . unScopeGraph +ddataOfScope scope = fmap declarations . Map.lookup scope . graph linksOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map EdgeLabel [scope]) -linksOfScope scope = fmap edges . Map.lookup scope . fst . unScopeGraph +linksOfScope scope = fmap edges . Map.lookup scope . graph lookupScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Scope scope) -lookupScope scope = Map.lookup scope . fst . unScopeGraph - -currentScope :: ScopeGraph scope -> scope -currentScope = snd . unScopeGraph - -scopeGraph :: ScopeGraph scope -> Map scope (Scope scope) -scopeGraph = fst . unScopeGraph +lookupScope scope = Map.lookup scope . graph declare :: Ord scope => Declaration -> Span -> ScopeGraph scope -> ScopeGraph scope -declare declaration ddata graph = let scopeKey = currentScope graph - in case lookupScope scopeKey graph of - Just scope -> let newScope = scope { declarations = Map.insert declaration ddata (declarations scope) } - in graph { unScopeGraph = (Map.insert scopeKey newScope (fst $ unScopeGraph graph), scopeKey) } - Nothing -> graph +declare declaration ddata g@ScopeGraph{..} = fromMaybe g $ do + scopeKey <- currentScope + scope <- lookupScope scopeKey g + let newScope = scope { declarations = Map.insert declaration ddata (declarations scope) } + pure $ g { graph = (Map.insert scopeKey newScope graph) } reference :: Ord scope => Reference -> Declaration -> ScopeGraph scope -> ScopeGraph scope -reference ref declaration graph = let - currentAddress = currentScope graph - declDataOfScope address = do - dataMap <- ddataOfScope address graph - Map.lookup declaration dataMap - go currentScope address path = - case declDataOfScope address of - Just ddata -> - let newScope = currentScope { references = Map.insert ref (path (DPath declaration)) (references currentScope) } - in Just (graph { unScopeGraph = (Map.insert currentAddress newScope (scopeGraph graph), currentAddress) }) - Nothing -> let - traverseEdges edge = do - linkMap <- linksOfScope address graph - scopes <- Map.lookup edge linkMap - -- Return the first path to the declaration through the scopes. - getFirst (foldMap (First . ap (go currentScope) ((path .) . EPath edge)) scopes) - in traverseEdges P <|> traverseEdges I - in case lookupScope currentAddress graph of - Just currentScope -> fromMaybe graph (go currentScope currentAddress id) - Nothing -> graph +reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do + currentAddress <- currentScope + currentScope' <- lookupScope currentAddress g + go currentAddress currentScope' currentAddress id + where + declDataOfScope address = do + dataMap <- ddataOfScope address g + Map.lookup declaration dataMap + go currentAddress currentScope address path = + case declDataOfScope address of + Just ddata -> + let newScope = currentScope { references = Map.insert ref (path (DPath declaration)) (references currentScope) } + in Just (g { graph = Map.insert currentAddress newScope graph }) + Nothing -> let + traverseEdges edge = do + linkMap <- linksOfScope address g + scopes <- Map.lookup edge linkMap + -- Return the first path to the declaration through the scopes. + getFirst (foldMap (First . ap (go currentAddress currentScope) ((path .) . EPath edge)) scopes) + in traverseEdges P <|> traverseEdges I create :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address -create address edges graph = graph { unScopeGraph = (Map.insert address newScope (scopeGraph graph), address) } +create address edges g@ScopeGraph{..} = g { graph = Map.insert address newScope graph, currentScope = Just address } where newScope = Scope edges mempty mempty scopeOfRef :: Ord scope => Reference -> ScopeGraph scope -> Maybe scope -scopeOfRef ref graph = go . Map.keys . fst $ unScopeGraph graph +scopeOfRef ref g@ScopeGraph{..} = go (Map.keys graph) where - go (s : scopes') = case pathsOfScope s graph of - Just pathMap -> case Map.lookup ref pathMap of - Just _ -> Just s - Nothing -> go scopes' - Nothing -> go scopes' + go (s : scopes') = fromMaybe (go scopes') $ do + pathMap <- pathsOfScope s g + _ <- Map.lookup ref pathMap + pure (Just s) go [] = Nothing pathOfRef :: (Ord scope) => Reference -> ScopeGraph scope -> Maybe (Path scope) @@ -126,13 +118,12 @@ pathOfRef ref graph = do Map.lookup ref pathsMap scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope -scopeOfDeclaration declaration graph = go . Map.keys . fst $ unScopeGraph graph +scopeOfDeclaration declaration g@ScopeGraph{..} = go (Map.keys graph) where - go (s : scopes') = case ddataOfScope s graph of - Just ddataMap -> case Map.lookup declaration ddataMap of - Just _ -> Just s - Nothing -> go scopes' - Nothing -> go scopes' + go (s : scopes') = fromMaybe (go scopes') $ do + ddataMap <- ddataOfScope s g + _ <- Map.lookup declaration ddataMap + pure (Just s) go [] = Nothing newtype Reference = Reference Name From 423a82481d1dbdfbbfb63822e49a5281aa76b6bc Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 13 Sep 2018 17:42:18 -0400 Subject: [PATCH 24/72] Pass an action to create so we can pop child scopes off --- src/Control/Abstract/ScopeGraph.hs | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 571d3b2c1..4bd55c049 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -25,8 +25,8 @@ data ScopeEnv address (m :: * -> *) a where Lookup :: Reference -> ScopeEnv address m (Maybe address) Declare :: Declaration -> Span -> ScopeEnv address m () Reference :: Reference -> Declaration -> ScopeEnv address m () - Create :: Map EdgeLabel [address] -> ScopeEnv address m () - CurrentScope :: ScopeEnv address m address + Create :: Map EdgeLabel [address] -> m a -> ScopeEnv address m a + CurrentScope :: ScopeEnv address m (Maybe address) lookup :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator address value effects (Maybe address) lookup = send . Lookup @address @@ -37,10 +37,10 @@ declare = (send .) . Declare @address reference :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator address value effects () reference = (send .) . Reference @address -newScope :: forall address value effects. Member (ScopeEnv address) effects => Map EdgeLabel [address] -> Evaluator address value effects () -newScope = send . Create @address +newScope :: forall address value effects m a. (Effectful m, Member (ScopeEnv address) effects) => Map EdgeLabel [address] -> m effects a -> Evaluator address value effects a +newScope map action= send (Create map (lowerEff action)) -currentScope :: forall address value effects. Member (ScopeEnv address) effects => Evaluator address value effects address +currentScope :: forall address value effects. Member (ScopeEnv address) effects => Evaluator address value effects (Maybe address) currentScope = send CurrentScope instance PureEffect (ScopeEnv address) @@ -48,26 +48,28 @@ instance Effect (ScopeEnv address) where handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) handleState c dist (Request (Declare decl ddata) k) = Request (Declare decl ddata) (dist . (<$ c) . k) handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k) - handleState c dist (Request (Create edges) k) = Request (Create edges) (dist . (<$ c) . k) + handleState c dist (Request (Create edges action) k) = Request (Create edges (dist (action <$ c))) (dist . fmap k) handleState c dist (Request CurrentScope k) = Request CurrentScope (dist . (<$ c) . k) runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects) => Evaluator address value (ScopeEnv address ': effects) a -> Evaluator address value effects (ScopeGraph address, a) -runScopeEnv evaluator = do - name <- gensym - address <- alloc name - runState (ScopeGraph.emptyGraph address) (reinterpret handleScopeEnv evaluator) +runScopeEnv evaluator = runState (ScopeGraph.emptyGraph) (reinterpret handleScopeEnv evaluator) -handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects) +handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects, Effects effects) => ScopeEnv address (Eff (ScopeEnv address ': effects)) a -> Evaluator address value (State (ScopeGraph address) ': effects) a handleScopeEnv = \case Lookup ref -> ScopeGraph.scopeOfRef ref <$> get Declare decl ddata -> modify @(ScopeGraph address) (ScopeGraph.declare decl ddata) Reference ref decl -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) - Create edges -> do + Create edges action -> do + -- Take the edges and construct a new scope, update the current scope to the new scope + currentScope' <- ScopeGraph.currentScope <$> get name <- gensym address <- alloc name modify @(ScopeGraph address) (ScopeGraph.create address edges) + value <- reinterpret handleScopeEnv (raiseEff action) + modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = currentScope' }) + pure value CurrentScope -> ScopeGraph.currentScope <$> get From 8d89393e49f577e30991e3ef64ba30c3d21aa1f2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 13 Sep 2018 17:46:25 -0400 Subject: [PATCH 25/72] Add Ord constraint --- src/Semantic/Graph.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 057accc7e..f77b23d35 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -351,6 +351,7 @@ resumingLoadError :: ( Applicative (m address value effects) , Effectful (m address value) , Effects effects , Member Trace effects + , Ord address ) => m address value (Resumable (BaseError (LoadError address)) ': effects) a -> m address value effects a From 442fe397257f4f2a85282684297018b586f8f1ff Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 13 Sep 2018 17:46:46 -0400 Subject: [PATCH 26/72] Run the class's children in its scope --- src/Data/Syntax/Declaration.hs | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 1f7948236..c2ea66686 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -209,17 +209,19 @@ instance Evaluatable Class where span <- ask @Span -- Add the class to the current scope. declare (Declaration name) span - -- Start a new scope. + -- Run the action within the class's scope. currentScope' <- currentScope - newScope (Map.singleton P [ currentScope' ]) + let edges = maybe mempty (Map.singleton P . pure) currentScope' + newScope edges $ do + supers <- traverse subtermAddress classSuperclasses + (_, addr) <- letrec name $ do + void $ subtermValue classBody + classBinds <- Env.head <$> getEnv + klass name supers classBinds + bind name addr + pure (Rval addr) + - supers <- traverse subtermAddress classSuperclasses - (_, addr) <- letrec name $ do - void $ subtermValue classBody - classBinds <- Env.head <$> getEnv - klass name supers classBinds - bind name addr - pure (Rval addr) -- | A decorator in Python data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a } From 0cdbd1e51d3a4e039557bcd69b3f8c61799517b1 Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 13 Sep 2018 17:46:59 -0400 Subject: [PATCH 27/72] Run a statements children within its scope --- src/Data/Syntax/Statement.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 611ca4e5a..c2c35278e 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -3,6 +3,8 @@ module Data.Syntax.Statement where import Data.Abstract.Evaluatable +import Control.Abstract.ScopeGraph +import qualified Data.Map.Strict as Map import Data.Aeson (ToJSON1 (..)) import Data.JSON.Fields import Data.Semigroup.App @@ -27,7 +29,10 @@ instance Show1 Statements where liftShowsPrec = genericLiftShowsPrec instance ToJSON1 Statements instance Evaluatable Statements where - eval (Statements xs) = maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs) + eval (Statements xs) = do + currentScope' <- currentScope + let edges = maybe mempty (Map.singleton P . pure) currentScope' + newScope edges $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs) instance Tokenize Statements where tokenize = imperative From c61c592ef658a56a45461f1c9eea5384c3350aee Mon Sep 17 00:00:00 2001 From: joshvera Date: Thu, 13 Sep 2018 18:27:19 -0400 Subject: [PATCH 28/72] Prefer import edges over parent edges --- src/Data/Abstract/ScopeGraph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index bc19f02bb..580ddd5ce 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -95,7 +95,7 @@ reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do scopes <- Map.lookup edge linkMap -- Return the first path to the declaration through the scopes. getFirst (foldMap (First . ap (go currentAddress currentScope) ((path .) . EPath edge)) scopes) - in traverseEdges P <|> traverseEdges I + in traverseEdges I <|> traverseEdges P create :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address create address edges g@ScopeGraph{..} = g { graph = Map.insert address newScope graph, currentScope = Just address } From d19b861cbe437650eef86f943e70d7b23534f4e3 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 11:35:43 -0400 Subject: [PATCH 29/72] Eval instance for New --- src/Data/Syntax/Expression.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index d5655d313..4015fc3ff 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -530,7 +530,10 @@ instance Ord1 New where liftCompare = genericLiftCompare instance Show1 New where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for New -instance Evaluatable New +instance Evaluatable New where + eval (New a) = + -- TODO: Traverse subterms and instantiate frames from the corresponding scope + rvalBox unit -- | A cast expression to a specified type. data Cast a = Cast { castSubject :: !a, castType :: !a } From ce2263d5e587ac24ae0f96fd533970e9900ae69c Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 15:12:29 -0400 Subject: [PATCH 30/72] Set a declaration's scope on assignment --- src/Control/Abstract/ScopeGraph.hs | 55 +++++++++++++++++++++--------- src/Data/Abstract/ScopeGraph.hs | 35 ++++++++++++++----- src/Data/Syntax/Declaration.hs | 10 +++--- src/Data/Syntax/Expression.hs | 22 ++++++++++-- src/Data/Syntax/Statement.hs | 16 +++++++-- 5 files changed, 104 insertions(+), 34 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 4bd55c049..69e532d88 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -10,9 +10,12 @@ module Control.Abstract.ScopeGraph , Reference(..) , EdgeLabel(..) , currentScope + , withScope + , associatedScope + , putDeclarationScope ) where -import Control.Abstract.Evaluator +import Control.Abstract.Evaluator hiding (Local) import Control.Abstract.Heap import Data.Abstract.Name import Data.Abstract.ScopeGraph (Declaration (..), EdgeLabel, Reference, ScopeGraph) @@ -23,33 +26,49 @@ import Prologue data ScopeEnv address (m :: * -> *) a where Lookup :: Reference -> ScopeEnv address m (Maybe address) - Declare :: Declaration -> Span -> ScopeEnv address m () + Declare :: Declaration -> Span -> Maybe address -> ScopeEnv address m () + PutDeclarationScope :: Declaration -> address -> ScopeEnv address m () Reference :: Reference -> Declaration -> ScopeEnv address m () - Create :: Map EdgeLabel [address] -> m a -> ScopeEnv address m a + NewScope :: Map EdgeLabel [address] -> ScopeEnv address m address CurrentScope :: ScopeEnv address m (Maybe address) + Local :: address -> m a -> ScopeEnv address m a + AssociatedScope :: Declaration -> ScopeEnv address m (Maybe address) lookup :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Evaluator address value effects (Maybe address) lookup = send . Lookup @address -declare :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Evaluator address value effects () -declare = (send .) . Declare @address +declare :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Span -> Maybe address -> Evaluator address value effects () +declare = ((send .) .) . Declare @address + +putDeclarationScope :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> address -> Evaluator address value effects () +putDeclarationScope = (send .) . PutDeclarationScope @address reference :: forall address value effects. Member (ScopeEnv address) effects => Reference -> Declaration -> Evaluator address value effects () reference = (send .) . Reference @address -newScope :: forall address value effects m a. (Effectful m, Member (ScopeEnv address) effects) => Map EdgeLabel [address] -> m effects a -> Evaluator address value effects a -newScope map action= send (Create map (lowerEff action)) +newScope :: forall address value effects. (Member (ScopeEnv address) effects) => Map EdgeLabel [address] -> Evaluator address value effects address +newScope map = send (NewScope map) currentScope :: forall address value effects. Member (ScopeEnv address) effects => Evaluator address value effects (Maybe address) currentScope = send CurrentScope +associatedScope :: forall address value effects. Member (ScopeEnv address) effects => Declaration -> Evaluator address value effects (Maybe address) +associatedScope = send . AssociatedScope + +withScope :: forall address value effects m a. (Effectful (m address value), Member (ScopeEnv address) effects) => address -> m address value effects a -> m address value effects a +withScope scope action = send (Local scope (lowerEff action)) + instance PureEffect (ScopeEnv address) instance Effect (ScopeEnv address) where handleState c dist (Request (Lookup ref) k) = Request (Lookup ref) (dist . (<$ c) . k) - handleState c dist (Request (Declare decl ddata) k) = Request (Declare decl ddata) (dist . (<$ c) . k) + handleState c dist (Request (Declare decl span assocScope) k) = Request (Declare decl span assocScope) (dist . (<$ c) . k) + handleState c dist (Request (PutDeclarationScope decl assocScope) k) = Request (PutDeclarationScope decl assocScope) (dist . (<$ c) . k) handleState c dist (Request (Reference ref decl) k) = Request (Reference ref decl) (dist . (<$ c) . k) - handleState c dist (Request (Create edges action) k) = Request (Create edges (dist (action <$ c))) (dist . fmap k) + handleState c dist (Request (NewScope edges) k) = Request (NewScope edges) (dist . (<$ c) . k) handleState c dist (Request CurrentScope k) = Request CurrentScope (dist . (<$ c) . k) + handleState c dist (Request (AssociatedScope decl) k) = Request (AssociatedScope decl) (dist . (<$ c) . k) + handleState c dist (Request (Local scope action) k) = Request (Local scope (dist (action <$ c))) (dist . fmap k) + runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects) => Evaluator address value (ScopeEnv address ': effects) a @@ -61,15 +80,19 @@ handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh eff -> Evaluator address value (State (ScopeGraph address) ': effects) a handleScopeEnv = \case Lookup ref -> ScopeGraph.scopeOfRef ref <$> get - Declare decl ddata -> modify @(ScopeGraph address) (ScopeGraph.declare decl ddata) + Declare decl span scope -> modify @(ScopeGraph address) (ScopeGraph.declare decl span scope) + PutDeclarationScope decl scope -> modify @(ScopeGraph address) (ScopeGraph.insertDeclarationScope decl scope) Reference ref decl -> modify @(ScopeGraph address) (ScopeGraph.reference ref decl) - Create edges action -> do + NewScope edges -> do -- Take the edges and construct a new scope, update the current scope to the new scope - currentScope' <- ScopeGraph.currentScope <$> get name <- gensym address <- alloc name - modify @(ScopeGraph address) (ScopeGraph.create address edges) - value <- reinterpret handleScopeEnv (raiseEff action) - modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = currentScope' }) - pure value + address <$ modify @(ScopeGraph address) (ScopeGraph.newScope address edges) CurrentScope -> ScopeGraph.currentScope <$> get + AssociatedScope decl -> ScopeGraph.associatedScope decl <$> get + Local scope action -> do + prevScope <- ScopeGraph.currentScope <$> get + modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = Just scope }) + value <- reinterpret handleScopeEnv (raiseEff action) + modify @(ScopeGraph address) (\g -> g { ScopeGraph.currentScope = prevScope }) + pure value diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 580ddd5ce..a8e2d8899 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -17,7 +17,9 @@ module Data.Abstract.ScopeGraph , declare , emptyGraph , reference - , create + , newScope + , associatedScope + , insertDeclarationScope ) where import Data.Abstract.Live @@ -31,7 +33,7 @@ import Prologue data Scope scopeAddress = Scope { edges :: Map EdgeLabel [scopeAddress] -- Maybe Map EdgeLabel [Path scope]? , references :: Map Reference (Path scopeAddress) - , declarations :: Map Declaration Span + , declarations :: Map Declaration (Span, Maybe scopeAddress) } deriving (Eq, Show, Ord) @@ -59,7 +61,7 @@ pathDeclaration (EPath _ _ p) = pathDeclaration p pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference (Path scope)) pathsOfScope scope = fmap references . Map.lookup scope . graph -ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Declaration Span) +ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Declaration (Span, Maybe scope)) ddataOfScope scope = fmap declarations . Map.lookup scope . graph linksOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map EdgeLabel [scope]) @@ -68,11 +70,11 @@ linksOfScope scope = fmap edges . Map.lookup scope . graph lookupScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Scope scope) lookupScope scope = Map.lookup scope . graph -declare :: Ord scope => Declaration -> Span -> ScopeGraph scope -> ScopeGraph scope -declare declaration ddata g@ScopeGraph{..} = fromMaybe g $ do +declare :: Ord scope => Declaration -> Span -> Maybe scope -> ScopeGraph scope -> ScopeGraph scope +declare declaration ddata assocScope g@ScopeGraph{..} = fromMaybe g $ do scopeKey <- currentScope scope <- lookupScope scopeKey g - let newScope = scope { declarations = Map.insert declaration ddata (declarations scope) } + let newScope = scope { declarations = Map.insert declaration (ddata, assocScope) (declarations scope) } pure $ g { graph = (Map.insert scopeKey newScope graph) } reference :: Ord scope => Reference -> Declaration -> ScopeGraph scope -> ScopeGraph scope @@ -97,8 +99,15 @@ reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do getFirst (foldMap (First . ap (go currentAddress currentScope) ((path .) . EPath edge)) scopes) in traverseEdges I <|> traverseEdges P -create :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address -create address edges g@ScopeGraph{..} = g { graph = Map.insert address newScope graph, currentScope = Just address } +insertDeclarationScope :: Ord address => Declaration -> address -> ScopeGraph address -> ScopeGraph address +insertDeclarationScope decl address g@ScopeGraph{..} = fromMaybe g $ do + declScope <- scopeOfDeclaration decl g + scope <- lookupScope declScope g + (span, _) <- Map.lookup decl (declarations scope) + pure $ g { graph = Map.insert declScope (scope { declarations = Map.insert decl (span, Just address) (declarations scope) }) graph } + +newScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address +newScope address edges g@ScopeGraph{..} = g { graph = Map.insert address newScope graph } where newScope = Scope edges mempty mempty @@ -117,6 +126,7 @@ pathOfRef ref graph = do pathsMap <- pathsOfScope scope graph Map.lookup ref pathsMap +-- Returns the scope the declaration was declared in. scopeOfDeclaration :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope scopeOfDeclaration declaration g@ScopeGraph{..} = go (Map.keys graph) where @@ -126,6 +136,15 @@ scopeOfDeclaration declaration g@ScopeGraph{..} = go (Map.keys graph) pure (Just s) go [] = Nothing +associatedScope :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope +associatedScope declaration g@ScopeGraph{..} = go (Map.keys graph) + where + go (s : scopes') = fromMaybe (go scopes') $ do + ddataMap <- ddataOfScope s g + (_, assocScope) <- Map.lookup declaration ddataMap + pure assocScope + go [] = Nothing + newtype Reference = Reference Name deriving (Eq, Ord, Show) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index c2ea66686..1a1cf8467 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -135,7 +135,7 @@ instance Evaluatable VariableDeclaration where subtermSpan <- get @Span pure (subtermSpan, ref) - declare (Declaration name) span + declare (Declaration name) span Nothing -- TODO is it true that variable declarations never have an associated scope? address valueRef rvalBox =<< tuple addresses @@ -175,7 +175,7 @@ instance Evaluatable PublicFieldDefinition where eval PublicFieldDefinition{..} = do span <- ask @Span propertyName <- maybeM (throwEvalError NoNameError) (declaredName (subterm publicFieldPropertyName)) - declare (Declaration propertyName) span + declare (Declaration propertyName) span Nothing rvalBox unit @@ -207,12 +207,12 @@ instance Evaluatable Class where eval Class{..} = do name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier)) span <- ask @Span - -- Add the class to the current scope. - declare (Declaration name) span -- Run the action within the class's scope. currentScope' <- currentScope let edges = maybe mempty (Map.singleton P . pure) currentScope' - newScope edges $ do + childScope <- newScope edges + declare (Declaration name) span (Just childScope) + withScope childScope $ do supers <- traverse subtermAddress classSuperclasses (_, addr) <- letrec name $ do void $ subtermValue classBody diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 4015fc3ff..d641c2ce7 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -2,6 +2,8 @@ {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Expression where +import qualified Data.Map.Strict as Map +import Control.Abstract.ScopeGraph as ScopeGraph import Data.Abstract.Evaluatable hiding (Member) import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv) import Data.Bits @@ -432,7 +434,17 @@ instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec instance Evaluatable MemberAccess where eval (MemberAccess obj propName) = do + name <- maybeM (throwEvalError NoNameError) (declaredName (subterm obj)) + reference (Reference name) (Declaration name) + childScope <- associatedScope (Declaration name) + ptr <- subtermAddress obj + case childScope of + Just childScope -> withScope childScope $ reference (Reference propName) (Declaration propName) + Nothing -> + -- TODO: Throw an ReferenceError because we can't find the associated child scope for `obj`. + pure () + pure $! LvalMember ptr propName -- | Subscript (e.g a[1]) @@ -523,7 +535,11 @@ instance Evaluatable Await where -- | An object constructor call in Javascript, Java, etc. newtype New a = New { newSubject :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + +instance Declarations1 New where + liftDeclaredName _ (New []) = Nothing + liftDeclaredName declaredName (New (subject : _)) = declaredName subject instance Eq1 New where liftEq = genericLiftEq instance Ord1 New where liftCompare = genericLiftCompare @@ -531,7 +547,9 @@ instance Show1 New where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for New instance Evaluatable New where - eval (New a) = + eval (New [subject]) = do + name <- maybeM (throwEvalError NoNameError) (declaredName (subterm subject)) + reference (Reference name) (Declaration name) -- TODO: Traverse subterms and instantiate frames from the corresponding scope rvalBox unit diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index c2c35278e..d10cd1324 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -32,7 +32,8 @@ instance Evaluatable Statements where eval (Statements xs) = do currentScope' <- currentScope let edges = maybe mempty (Map.singleton P . pure) currentScope' - newScope edges $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs) + scope <- newScope edges + withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs) instance Tokenize Statements where tokenize = imperative @@ -141,8 +142,17 @@ instance Evaluatable Assignment where rhs <- subtermAddress assignmentValue case lhs of - LvalLocal nam -> do - bind nam rhs + LvalLocal name -> do + case (declaredName (subterm assignmentValue)) of + Just rhsName -> do + assocScope <- associatedScope (Declaration rhsName) + let edges = maybe mempty (Map.singleton I . pure) assocScope + objectScope <- newScope edges + putDeclarationScope (Declaration name) objectScope + Nothing -> + -- The rhs wasn't assigned to a reference/declaration. + pure () + bind name rhs LvalMember _ _ -> -- we don't yet support mutable object properties: pure () From 41881f30575f4c8a3c48014d76fb14b088b1e5b7 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 17:06:26 -0400 Subject: [PATCH 31/72] Add edges to superclasses --- src/Data/Syntax/Declaration.hs | 14 +++++++++++--- src/Language/TypeScript/Syntax/TypeScript.hs | 20 +++++++++++++++++--- 2 files changed, 28 insertions(+), 6 deletions(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 1a1cf8467..3d4275c64 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -209,15 +209,23 @@ instance Evaluatable Class where span <- ask @Span -- Run the action within the class's scope. currentScope' <- currentScope - let edges = maybe mempty (Map.singleton P . pure) currentScope' + + supers <- for classSuperclasses $ \superclass -> do + name <- maybeM (throwEvalError NoNameError) (declaredName (subterm superclass)) + scope <- associatedScope (Declaration name) + (scope,) <$> subtermAddress superclass + + let imports = ((I,) <$> (fmap pure . catMaybes $ fst <$> supers)) + current = maybe mempty (fmap (P, ) . pure . pure) currentScope' + edges = Map.fromList (imports <> current) childScope <- newScope edges declare (Declaration name) span (Just childScope) + withScope childScope $ do - supers <- traverse subtermAddress classSuperclasses (_, addr) <- letrec name $ do void $ subtermValue classBody classBinds <- Env.head <$> getEnv - klass name supers classBinds + klass name (snd <$> supers) classBinds bind name addr pure (Rval addr) diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index 827d77aab..af1c39d7b 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -284,7 +284,12 @@ instance Declarations1 TypeIdentifier where instance Eq1 TypeIdentifier where liftEq = genericLiftEq instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable TypeIdentifier +-- TODO: TypeIdentifier shouldn't evaluate to an address in the heap? +instance Evaluatable TypeIdentifier where + eval TypeIdentifier{..} = do + -- Add a reference to the type identifier in the current scope. + reference (Reference (name contents)) (Declaration (name contents)) + rvalBox unit data NestedIdentifier a = NestedIdentifier { left :: !a, right :: !a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) @@ -348,12 +353,21 @@ instance Declarations a => Declarations (EnumDeclaration a) where declaredName EnumDeclaration{..} = declaredName enumDeclarationIdentifier newtype ExtendsClause a = ExtendsClause { extendsClauses :: [a] } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) + +instance Declarations1 ExtendsClause where + liftDeclaredName _ (ExtendsClause []) = Nothing + liftDeclaredName declaredName (ExtendsClause (x : _)) = declaredName x instance Eq1 ExtendsClause where liftEq = genericLiftEq instance Ord1 ExtendsClause where liftCompare = genericLiftCompare instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable ExtendsClause +-- TODO: ExtendsClause shouldn't evaluate to an address in the heap? +instance Evaluatable ExtendsClause where + eval ExtendsClause{..} = do + -- Evaluate subterms + _ <- traverse subtermRef extendsClauses + rvalBox unit newtype ArrayType a = ArrayType { arrayType :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Message1, Named1, Ord, Show, ToJSONFields1, Traversable) From eb71b512b347b419bed443dc058dcd12786009cb Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 18:04:08 -0400 Subject: [PATCH 32/72] Fix test type errors --- src/Data/Abstract/Evaluatable.hs | 2 +- test/Analysis/Go/Spec.hs | 4 ++-- test/Analysis/PHP/Spec.hs | 6 +++--- test/Analysis/Python/Spec.hs | 12 ++++++------ test/Analysis/Ruby/Spec.hs | 22 +++++++++++----------- test/Analysis/TypeScript/Spec.hs | 30 +++++++++++++++--------------- test/SpecHelpers.hs | 8 +++++--- 7 files changed, 43 insertions(+), 41 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index d9c632703..ebd8f6d1d 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -129,7 +129,7 @@ evaluate :: ( AbstractValue address value valueEffects -> [Module term] -> TermEvaluator term address value effects (ModuleTable (NonEmpty (Module (ModuleResult address)))) evaluate lang analyzeModule analyzeTerm runAllocDeref runValue modules = do - (scopeGraph, (preludeBinds, _)) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack . runValue $ do + (_, (preludeBinds, _)) <- TermEvaluator . runInModule lowerBound moduleInfoFromCallStack . runValue $ do definePrelude lang box unit foldr (run preludeBinds) ask modules diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 08e2e5bd0..83cb8b9dc 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -14,7 +14,7 @@ spec config = parallel $ do it "imports and wildcard imports" $ do (_, (heap, res)) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"] case ModuleTable.lookup "main.go" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do Env.names env `shouldBe` [ "Bar", "Rab", "foo", "main" ] (derefQName heap ("foo" :| []) env >>= deNamespace heap) `shouldBe` Just ("foo", ["New"]) other -> expectationFailure (show other) @@ -22,7 +22,7 @@ spec config = parallel $ do it "imports with aliases (and side effects only)" $ do (_, (heap, res)) <- evaluate ["main1.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"] case ModuleTable.lookup "main1.go" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do Env.names env `shouldBe` [ "f", "main" ] (derefQName heap ("f" :| []) env >>= deNamespace heap) `shouldBe` Just ("f", ["New"]) other -> expectationFailure (show other) diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 7af3a6275..9609da774 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -15,7 +15,7 @@ spec config = parallel $ do it "evaluates include and require" $ do (_, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"] case ModuleTable.lookup "main.php" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do heapLookupAll addr heap `shouldBe` Just [unit] Env.names env `shouldBe` [ "bar", "foo" ] other -> expectationFailure (show other) @@ -23,7 +23,7 @@ spec config = parallel $ do it "evaluates include_once and require_once" $ do (_, (heap, res)) <- evaluate ["main_once.php", "foo.php", "bar.php"] case ModuleTable.lookup "main_once.php" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do heapLookupAll addr heap `shouldBe` Just [unit] Env.names env `shouldBe` [ "bar", "foo" ] other -> expectationFailure (show other) @@ -31,7 +31,7 @@ spec config = parallel $ do it "evaluates namespaces" $ do (_, (heap, res)) <- evaluate ["namespaces.php"] case ModuleTable.lookup "namespaces.php" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do Env.names env `shouldBe` [ "Foo", "NS1" ] (derefQName heap ("NS1" :| []) env >>= deNamespace heap) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index bab0e0ef8..4c38ebccd 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -16,7 +16,7 @@ spec config = parallel $ do it "imports" $ do (_, (heap, res)) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"] case ModuleTable.lookup "main.py" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do Env.names env `shouldContain` [ "a", "b" ] (derefQName heap ("a" :| []) env >>= deNamespace heap) `shouldBe` Just ("a", ["foo"]) @@ -27,19 +27,19 @@ spec config = parallel $ do it "imports with aliases" $ do (_, (_, res)) <- evaluate ["main1.py", "a.py", "b/__init__.py", "b/c.py"] case ModuleTable.lookup "main1.py" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> Env.names env `shouldContain` [ "b", "e" ] + Right (Just (Module _ (_, (env, addr)) :| [])) -> Env.names env `shouldContain` [ "b", "e" ] other -> expectationFailure (show other) it "imports using 'from' syntax" $ do (_, (_, res)) <- evaluate ["main2.py", "a.py", "b/__init__.py", "b/c.py"] case ModuleTable.lookup "main2.py" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> Env.names env `shouldContain` [ "bar", "foo" ] + Right (Just (Module _ (_, (env, addr)) :| [])) -> Env.names env `shouldContain` [ "bar", "foo" ] other -> expectationFailure (show other) it "imports with relative syntax" $ do (_, (heap, res)) <- evaluate ["main3.py", "c/__init__.py", "c/utils.py"] case ModuleTable.lookup "main3.py" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do Env.names env `shouldContain` [ "utils" ] (derefQName heap ("utils" :| []) env >>= deNamespace heap) `shouldBe` Just ("utils", ["to_s"]) other -> expectationFailure (show other) @@ -47,13 +47,13 @@ spec config = parallel $ do it "subclasses" $ do (_, (heap, res)) <- evaluate ["subclass.py"] case ModuleTable.lookup "subclass.py" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"bar\""] + Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"bar\""] other -> expectationFailure (show other) it "handles multiple inheritance left-to-right" $ do (_, (heap, res)) <- evaluate ["multiple_inheritance.py"] case ModuleTable.lookup "multiple_inheritance.py" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"foo!\""] + Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"foo!\""] other -> expectationFailure (show other) where diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 8a604c891..bd5b16c20 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -21,7 +21,7 @@ spec config = parallel $ do it "evaluates require_relative" $ do (_, (heap, res)) <- evaluate ["main.rb", "foo.rb"] case ModuleTable.lookup "main.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)] Env.names env `shouldContain` [ "foo" ] other -> expectationFailure (show other) @@ -29,7 +29,7 @@ spec config = parallel $ do it "evaluates load" $ do (_, (heap, res)) <- evaluate ["load.rb", "foo.rb"] case ModuleTable.lookup "load.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 1)] Env.names env `shouldContain` [ "foo" ] other -> expectationFailure (show other) @@ -41,7 +41,7 @@ spec config = parallel $ do it "evaluates subclass" $ do (_, (heap, res)) <- evaluate ["subclass.rb"] case ModuleTable.lookup "subclass.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do heapLookupAll addr heap `shouldBe` Just [String "\"\""] Env.names env `shouldContain` [ "Bar", "Foo" ] @@ -51,7 +51,7 @@ spec config = parallel $ do it "evaluates modules" $ do (_, (heap, res)) <- evaluate ["modules.rb"] case ModuleTable.lookup "modules.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do heapLookupAll addr heap `shouldBe` Just [String "\"\""] Env.names env `shouldContain` [ "Bar" ] other -> expectationFailure (show other) @@ -59,43 +59,43 @@ spec config = parallel $ do it "handles break correctly" $ do (_, (heap, res)) <- evaluate ["break.rb"] case ModuleTable.lookup "break.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)] + Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)] other -> expectationFailure (show other) it "handles next correctly" $ do (_, (heap, res)) <- evaluate ["next.rb"] case ModuleTable.lookup "next.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 8)] + Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 8)] other -> expectationFailure (show other) it "calls functions with arguments" $ do (_, (heap, res)) <- evaluate ["call.rb"] case ModuleTable.lookup "call.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 579)] + Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 579)] other -> expectationFailure (show other) it "evaluates early return statements" $ do (_, (heap, res)) <- evaluate ["early-return.rb"] case ModuleTable.lookup "early-return.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 123)] + Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 123)] other -> expectationFailure (show other) it "has prelude" $ do (_, (heap, res)) <- evaluate ["preluded.rb"] case ModuleTable.lookup "preluded.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"\""] + Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [String "\"\""] other -> expectationFailure (show other) it "evaluates __LINE__" $ do (_, (heap, res)) <- evaluate ["line.rb"] case ModuleTable.lookup "line.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)] + Right (Just (Module _ (_, (env, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)] other -> expectationFailure (show other) it "resolves builtins used in the prelude" $ do (traces, (heap, res)) <- evaluate ["puts.rb"] case ModuleTable.lookup "puts.rb" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do heapLookupAll addr heap `shouldBe` Just [Unit] traces `shouldContain` [ "\"hello\"" ] other -> expectationFailure (show other) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 6ebd635ff..24b3f501b 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -17,13 +17,13 @@ spec config = parallel $ do it "imports with aliased symbols" $ do (_, (_, res)) <- evaluate ["main.ts", "foo.ts", "a.ts", "foo/b.ts"] case ModuleTable.lookup "main.ts" <$> res of - Right (Just (Module _ (env, _) :| [])) -> Env.names env `shouldBe` [ "bar", "quz" ] + Right (Just (Module _ (_, (env, _)) :| [])) -> Env.names env `shouldBe` [ "bar", "quz" ] other -> expectationFailure (show other) it "imports with qualified names" $ do (_, (heap, res)) <- evaluate ["main1.ts", "foo.ts", "a.ts"] case ModuleTable.lookup "main1.ts" <$> res of - Right (Just (Module _ (env, _) :| [])) -> do + Right (Just (Module _ (_, (env, _)) :| [])) -> do Env.names env `shouldBe` [ "b", "z" ] (derefQName heap ("b" :| []) env >>= deNamespace heap) `shouldBe` Just ("b", [ "baz", "foo" ]) @@ -33,7 +33,7 @@ spec config = parallel $ do it "side effect only imports" $ do (_, (_, res)) <- evaluate ["main2.ts", "a.ts", "foo.ts"] case ModuleTable.lookup "main2.ts" <$> res of - Right (Just (Module _ (env, _) :| [])) -> env `shouldBe` lowerBound + Right (Just (Module _ (_, (env, _)) :| [])) -> env `shouldBe` lowerBound other -> expectationFailure (show other) it "fails exporting symbols not defined in the module" $ do @@ -43,13 +43,13 @@ spec config = parallel $ do it "evaluates early return statements" $ do (_, (heap, res)) <- evaluate ["early-return.ts"] case ModuleTable.lookup "early-return.ts" <$> res of - Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Float (Number.Decimal 123.0)] + Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Float (Number.Decimal 123.0)] other -> expectationFailure (show other) it "evaluates sequence expressions" $ do (_, (heap, res)) <- evaluate ["sequence-expression.ts"] case ModuleTable.lookup "sequence-expression.ts" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do Env.names env `shouldBe` [ "x" ] (derefQName heap ("x" :| []) env) `shouldBe` Just (Value.Float (Number.Decimal 3.0)) other -> expectationFailure (show other) @@ -57,13 +57,13 @@ spec config = parallel $ do it "evaluates void expressions" $ do (_, (heap, res)) <- evaluate ["void.ts"] case ModuleTable.lookup "void.ts" <$> res of - Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Null] + Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Null] other -> expectationFailure (show other) it "evaluates delete" $ do (_, (heap, res)) <- evaluate ["delete.ts"] case ModuleTable.lookup "delete.ts" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do heapLookupAll addr heap `shouldBe` Just [Unit] (derefQName heap ("x" :| []) env) `shouldBe` Nothing Env.names env `shouldBe` [ "x" ] @@ -72,7 +72,7 @@ spec config = parallel $ do it "evaluates await" $ do (_, (heap, res)) <- evaluate ["await.ts"] case ModuleTable.lookup "await.ts" <$> res of - Right (Just (Module _ (env, addr) :| [])) -> do + Right (Just (Module _ (_, (env, addr)) :| [])) -> do Env.names env `shouldBe` [ "f2" ] (derefQName heap ("y" :| []) env) `shouldBe` Nothing other -> expectationFailure (show other) @@ -80,41 +80,41 @@ spec config = parallel $ do it "evaluates BOr statements" $ do (_, (heap, res)) <- evaluate ["bor.ts"] case ModuleTable.lookup "bor.ts" <$> res of - Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)] + Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)] other -> expectationFailure (show other) it "evaluates BAnd statements" $ do (_, (heap, res)) <- evaluate ["band.ts"] case ModuleTable.lookup "band.ts" <$> res of - Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)] + Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)] other -> expectationFailure (show other) it "evaluates BXOr statements" $ do (_, (heap, res)) <- evaluate ["bxor.ts"] case ModuleTable.lookup "bxor.ts" <$> res of - Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)] + Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)] other -> expectationFailure (show other) it "evaluates LShift statements" $ do (_, (heap, res)) <- evaluate ["lshift.ts"] case ModuleTable.lookup "lshift.ts" <$> res of - Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)] + Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)] other -> expectationFailure (show other) it "evaluates RShift statements" $ do (_, (heap, res)) <- evaluate ["rshift.ts"] case ModuleTable.lookup "rshift.ts" <$> res of - Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)] + Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)] other -> expectationFailure (show other) it "evaluates Complement statements" $ do (_, (heap, res)) <- evaluate ["complement.ts"] case ModuleTable.lookup "complement.ts" <$> res of - Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer (-2))] + Right (Just (Module _ (_, (_, addr)) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer (-2))] other -> expectationFailure (show other) where fixtures = "test/fixtures/typescript/analysis/" evaluate = evalTypeScriptProject . map (fixtures <>) - evalTypeScriptProject = testEvaluating <=< evaluateProject' config (Proxy :: Proxy 'Language.TypeScript) typescriptParser + evalTypeScriptProject = testEvaluating <=< (evaluateProject' config (Proxy :: Proxy 'Language.TypeScript) typescriptParser) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 34bd5be0b..c219edc9a 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -118,12 +118,12 @@ type TestEvaluatingErrors = '[ BaseError (ValueError Precise (ConcreteEff Precis , BaseError (UnspecializedError Val) , BaseError (LoadError Precise) ] -testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (ModuleTable (NonEmpty (Module (ModuleResult Precise)))) +testEvaluating :: Evaluator Precise Val TestEvaluatingEffects (Span, a) -> IO ( [String] , ( Heap Precise Val , Either (SomeExc (Data.Sum.Sum TestEvaluatingErrors)) - (ModuleTable (NonEmpty (Module (ModuleResult Precise)))) + a ) ) testEvaluating @@ -139,6 +139,7 @@ testEvaluating . runResolutionError . runAddressError . runValueError @_ @Precise @(ConcreteEff Precise _) + . fmap snd type Val = Value Precise (ConcreteEff Precise '[Trace, Lift IO]) @@ -153,11 +154,12 @@ namespaceScope :: Heap Precise (Value Precise term) -> Value Precise term -> Maybe (Environment Precise) namespaceScope heap ns@(Namespace _ _ _) - = either (const Nothing) snd + = either (const Nothing) (snd . snd) . run . runFresh 0 . runAddressError . runState heap + . runState (lowerBound @Span) . runReader (lowerBound @Span) . runReader (ModuleInfo "SpecHelper.hs") . runDeref From b70dd3102710da32c9b26fb00135a584b0675d18 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 18:14:02 -0400 Subject: [PATCH 33/72] Fix Declarations1 MemberAccess instance --- src/Data/Syntax/Expression.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index d641c2ce7..8b31ce818 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -426,7 +426,10 @@ instance Evaluatable Complement where -- | Member Access (e.g. a.b) data MemberAccess a = MemberAccess { lhs :: a, rhs :: Name } - deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + +instance Declarations1 MemberAccess where + liftDeclaredName _ MemberAccess{..} = Just rhs instance Eq1 MemberAccess where liftEq = genericLiftEq instance Ord1 MemberAccess where liftCompare = genericLiftCompare From a4f84f4371d1775a229ae0f2f4e49d5849cc104e Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 18:14:34 -0400 Subject: [PATCH 34/72] Remove scratch Scope file --- src/Scope.hs | 73 ---------------------------------------------------- 1 file changed, 73 deletions(-) delete mode 100644 src/Scope.hs diff --git a/src/Scope.hs b/src/Scope.hs deleted file mode 100644 index d8b8452c8..000000000 --- a/src/Scope.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE TypeOperators, PolyKinds, GADTs, TypeFamilies, UndecidableInstances, RankNTypes #-} -module Scope (declsOf, edgesOf, Scope, Graph) where - -import Data.Kind (Type) -import Data.Finite -import GHC.TypeLits - --- Scope Graphs --- Type aliases for scope identifiers (`Scope`) and scope graphs (`Graph`). -type Scope k = Finite k - -newtype Graph ty k = Graph { unGraph :: Scope k -> ([ty], [Scope k]) } - -declsOf :: Graph ty k -> Scope k -> [ty] -declsOf g = fst . unGraph g - -edgesOf :: Graph ty k -> Scope k -> [Scope k] -edgesOf g = snd . unGraph g - -type family Fst (k :: (m, n)) where - Fst '(a, b) = a - --- type family EdgesOf (g :: Graph ty (k :: 'Nat)) (s :: y) :: [y] where --- EdgesOf g s = Fst (g s) - -data (––>) x y where - Empty :: s ––> s - -- TODO: `s` here was previously `Member s' (EdgesOf s)` - Cons :: s -> s' ––> s'' -> s ––> s'' - -concat :: s ––> s' -> s' ––> s'' -> s ––> s'' -concat Empty s2 = s2 -concat (Cons a s1) s2 = (Cons a (Scope.concat s1 s2)) - -data (|>) s name where - Path :: s ––> s' -> name -> s |> name - -prepend :: s ––> s' -> s' |> name -> s |> name -prepend p (Path p' name) = Path (Scope.concat p p') name - -type HeapTy address = [address] - -type HeapTy k = [Scope k] - -data FramePtr address where - FramePtr :: address -> HeapTy address -> FramePtr address - -data Slots ty address where - Slots :: [ty] -> HeapTy address -> Slots ty address - -data Links address where - Links :: [address] -> HeapTy address -> Links address - -data HeapFrame address where - HeapFrame :: Scope address -> HeapTy address -> HeapFrame address - -data Heap address where - Heap :: HeapTy address -> Heap address - - --- Store frames in the heap --- Lookup frame in the scope graph for a resolution path --- Apply resolution path in the heap to get the value of a probably well-typed address. --- Environment may be subsumed by a Reader of the current scope in the scope graph. --- The scope graph is probably the primary data structure. --- We shouldn't be concerned with the shapes of the frames as long as they correspond to the correct side-effects. - - --- Figure out how to look up names in the scope graph - - --- data Scope m a where --- GetFrame :: s ––> s' -> Frame s e -> Heap e -> Scope m (Frame s' e) From 8e1e9579da82ef8a709b6a80c9509052f2e74ada Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 18:16:54 -0400 Subject: [PATCH 35/72] lints --- src/Control/Abstract/ScopeGraph.hs | 2 +- src/Data/Abstract/ScopeGraph.hs | 4 ++-- src/Data/Syntax/Declaration.hs | 2 +- src/Data/Syntax/Statement.hs | 2 +- src/Language/TypeScript/Syntax/TypeScript.hs | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 69e532d88..86c889d97 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -73,7 +73,7 @@ instance Effect (ScopeEnv address) where runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects) => Evaluator address value (ScopeEnv address ': effects) a -> Evaluator address value effects (ScopeGraph address, a) -runScopeEnv evaluator = runState (ScopeGraph.emptyGraph) (reinterpret handleScopeEnv evaluator) +runScopeEnv evaluator = runState ScopeGraph.emptyGraph (reinterpret handleScopeEnv evaluator) handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects, Effects effects) => ScopeEnv address (Eff (ScopeEnv address ': effects)) a diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index a8e2d8899..0908d9961 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GADTs #-} module Data.Abstract.ScopeGraph ( ScopeGraph(..) , Path @@ -75,7 +75,7 @@ declare declaration ddata assocScope g@ScopeGraph{..} = fromMaybe g $ do scopeKey <- currentScope scope <- lookupScope scopeKey g let newScope = scope { declarations = Map.insert declaration (ddata, assocScope) (declarations scope) } - pure $ g { graph = (Map.insert scopeKey newScope graph) } + pure $ g { graph = Map.insert scopeKey newScope graph } reference :: Ord scope => Reference -> Declaration -> ScopeGraph scope -> ScopeGraph scope reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 3d4275c64..b4d02b158 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -215,7 +215,7 @@ instance Evaluatable Class where scope <- associatedScope (Declaration name) (scope,) <$> subtermAddress superclass - let imports = ((I,) <$> (fmap pure . catMaybes $ fst <$> supers)) + let imports = (I,) <$> (fmap pure . catMaybes $ fst <$> supers) current = maybe mempty (fmap (P, ) . pure . pure) currentScope' edges = Map.fromList (imports <> current) childScope <- newScope edges diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index d10cd1324..35d67d044 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -143,7 +143,7 @@ instance Evaluatable Assignment where case lhs of LvalLocal name -> do - case (declaredName (subterm assignmentValue)) of + case declaredName (subterm assignmentValue) of Just rhsName -> do assocScope <- associatedScope (Declaration rhsName) let edges = maybe mempty (Map.singleton I . pure) assocScope diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index af1c39d7b..c39134014 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -366,7 +366,7 @@ instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec instance Evaluatable ExtendsClause where eval ExtendsClause{..} = do -- Evaluate subterms - _ <- traverse subtermRef extendsClauses + traverse_ subtermRef extendsClauses rvalBox unit newtype ArrayType a = ArrayType { arrayType :: a } From 8bc8b196a23f7d5baaa420a9a6454092268dce66 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 18:25:24 -0400 Subject: [PATCH 36/72] docs --- src/Data/Abstract/ScopeGraph.hs | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 0908d9961..df819a54a 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -2,6 +2,7 @@ module Data.Abstract.ScopeGraph ( ScopeGraph(..) , Path + , pathDeclaration , Reference(..) , Declaration(..) , EdgeLabel(..) @@ -22,10 +23,8 @@ module Data.Abstract.ScopeGraph , insertDeclarationScope ) where -import Data.Abstract.Live import Data.Abstract.Name import qualified Data.Map.Strict as Map -import Data.Semigroup.Reducer import Data.Span import Prelude hiding (lookup) import Prologue @@ -47,29 +46,37 @@ deriving instance Show address => Show (ScopeGraph address) deriving instance Ord address => Ord (ScopeGraph address) data Path scope where + -- | Construct a direct path to a declaration. DPath :: Declaration -> Path scope + -- | Construct an edge from a scope to another declaration path. EPath :: EdgeLabel -> scope -> Path scope -> Path scope deriving instance Eq scope => Eq (Path scope) deriving instance Show scope => Show (Path scope) deriving instance Ord scope => Ord (Path scope) +-- Returns the declaration of a path. pathDeclaration :: Path scope -> Declaration pathDeclaration (DPath d) = d pathDeclaration (EPath _ _ p) = pathDeclaration p +-- Returns the reference paths of a scope in a scope graph. pathsOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Reference (Path scope)) pathsOfScope scope = fmap references . Map.lookup scope . graph +-- Returns the declaration data of a scope in a scope graph. ddataOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map Declaration (Span, Maybe scope)) ddataOfScope scope = fmap declarations . Map.lookup scope . graph +-- Returns the edges of a scope in a scope graph. linksOfScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Map EdgeLabel [scope]) linksOfScope scope = fmap edges . Map.lookup scope . graph +-- Lookup a scope in the scope graph. lookupScope :: Ord scope => scope -> ScopeGraph scope -> Maybe (Scope scope) lookupScope scope = Map.lookup scope . graph +-- Declare a declaration with a span and an associated scope in the scope graph. declare :: Ord scope => Declaration -> Span -> Maybe scope -> ScopeGraph scope -> ScopeGraph scope declare declaration ddata assocScope g@ScopeGraph{..} = fromMaybe g $ do scopeKey <- currentScope @@ -77,6 +84,8 @@ declare declaration ddata assocScope g@ScopeGraph{..} = fromMaybe g $ do let newScope = scope { declarations = Map.insert declaration (ddata, assocScope) (declarations scope) } pure $ g { graph = Map.insert scopeKey newScope graph } +-- | Add a reference to a declaration in the scope graph. +-- Returns the original scope graph if the declaration could not be found. reference :: Ord scope => Reference -> Declaration -> ScopeGraph scope -> ScopeGraph scope reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do currentAddress <- currentScope @@ -88,7 +97,7 @@ reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do Map.lookup declaration dataMap go currentAddress currentScope address path = case declDataOfScope address of - Just ddata -> + Just _ -> let newScope = currentScope { references = Map.insert ref (path (DPath declaration)) (references currentScope) } in Just (g { graph = Map.insert currentAddress newScope graph }) Nothing -> let @@ -99,6 +108,7 @@ reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do getFirst (foldMap (First . ap (go currentAddress currentScope) ((path .) . EPath edge)) scopes) in traverseEdges I <|> traverseEdges P +-- | Insert associate the given address to a declaration in the scope graph. insertDeclarationScope :: Ord address => Declaration -> address -> ScopeGraph address -> ScopeGraph address insertDeclarationScope decl address g@ScopeGraph{..} = fromMaybe g $ do declScope <- scopeOfDeclaration decl g @@ -106,11 +116,13 @@ insertDeclarationScope decl address g@ScopeGraph{..} = fromMaybe g $ do (span, _) <- Map.lookup decl (declarations scope) pure $ g { graph = Map.insert declScope (scope { declarations = Map.insert decl (span, Just address) (declarations scope) }) graph } +-- | Insert a new scope with the given address and edges into the scope graph. newScope :: Ord address => address -> Map EdgeLabel [address] -> ScopeGraph address -> ScopeGraph address newScope address edges g@ScopeGraph{..} = g { graph = Map.insert address newScope graph } where newScope = Scope edges mempty mempty +-- | Returns the scope of a reference in the scope graph. scopeOfRef :: Ord scope => Reference -> ScopeGraph scope -> Maybe scope scopeOfRef ref g@ScopeGraph{..} = go (Map.keys graph) where @@ -120,6 +132,7 @@ scopeOfRef ref g@ScopeGraph{..} = go (Map.keys graph) pure (Just s) go [] = Nothing +-- | Returns the path of a reference in the scope graph. pathOfRef :: (Ord scope) => Reference -> ScopeGraph scope -> Maybe (Path scope) pathOfRef ref graph = do scope <- scopeOfRef ref graph @@ -136,6 +149,7 @@ scopeOfDeclaration declaration g@ScopeGraph{..} = go (Map.keys graph) pure (Just s) go [] = Nothing +-- | Returns the scope associated with a declaration (the child scope if any exists). associatedScope :: Ord scope => Declaration -> ScopeGraph scope -> Maybe scope associatedScope declaration g@ScopeGraph{..} = go (Map.keys graph) where From 7d287a8ca734eff17416911c9f6db388ce48c5e2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 18:35:11 -0400 Subject: [PATCH 37/72] Remove declaration free variable and clean up lints --- src/Data/Abstract/ScopeGraph.hs | 42 ++++++++++++++++++++------------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index df819a54a..33a5c2a8e 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -6,6 +6,7 @@ module Data.Abstract.ScopeGraph , Reference(..) , Declaration(..) , EdgeLabel(..) + , Frame , Heap , frameLookup , scopeLookup @@ -15,12 +16,19 @@ module Data.Abstract.ScopeGraph , setSlot , lookup , scopeOfRef + , pathOfRef , declare , emptyGraph , reference , newScope , associatedScope , insertDeclarationScope + , newFrame + , initFrame + , insertFrame + , fillFrame + , deleteFrame + , heapSize ) where import Data.Abstract.Name @@ -168,68 +176,68 @@ newtype Declaration = Declaration Name data EdgeLabel = P | I deriving (Eq, Ord, Show) -data Frame scopeAddress frameAddress declaration value = Frame { +data Frame scopeAddress frameAddress value = Frame { scopeAddress :: scopeAddress , links :: Map EdgeLabel (Map scopeAddress frameAddress) - , slots :: Map declaration value + , slots :: Map Declaration value } -newtype Heap scopeAddress frameAddress declaration value = Heap { unHeap :: Map frameAddress (Frame scopeAddress frameAddress declaration value) } +newtype Heap scopeAddress frameAddress value = Heap { unHeap :: Map frameAddress (Frame scopeAddress frameAddress value) } -- | Look up the frame for an 'address' in a 'Heap', if any. -frameLookup :: Ord address => address -> Heap scope address declaration value -> Maybe (Frame scope address declaration value) +frameLookup :: Ord address => address -> Heap scope address value -> Maybe (Frame scope address value) frameLookup address = Map.lookup address . unHeap -- | Look up the scope address for a given frame address. -scopeLookup :: Ord address => address -> Heap scope address declaration value -> Maybe scope +scopeLookup :: Ord address => address -> Heap scope address value -> Maybe scope scopeLookup address = fmap scopeAddress . frameLookup address -frameSlots :: Ord address => address -> Heap scope address declaration value -> Maybe (Map declaration value) +frameSlots :: Ord address => address -> Heap scope address value -> Maybe (Map Declaration value) frameSlots address = fmap slots . frameLookup address -frameLinks :: Ord address => address -> Heap scope address declaration value -> Maybe (Map EdgeLabel (Map scope address)) +frameLinks :: Ord address => address -> Heap scope address value -> Maybe (Map EdgeLabel (Map scope address)) frameLinks address = fmap links . frameLookup address -getSlot :: (Ord address, Ord declaration) => address -> Heap scope address declaration value -> declaration -> Maybe value +getSlot :: Ord address => address -> Heap scope address value -> Declaration -> Maybe value getSlot address heap declaration = do slotMap <- frameSlots address heap Map.lookup declaration slotMap -setSlot :: (Ord address, Ord declaration) => address -> declaration -> value -> Heap scope address declaration value -> Heap scope address declaration value +setSlot :: Ord address => address -> Declaration -> value -> Heap scope address value -> Heap scope address value setSlot address declaration value heap = case frameLookup address heap of Just frame -> let slotMap = slots frame in Heap $ Map.insert address (frame { slots = Map.insert declaration value slotMap }) (unHeap heap) Nothing -> heap -lookup :: (Ord address, Ord scope) => Heap scope address declaration value -> address -> Path scope -> declaration -> Maybe scope -lookup heap address (DPath d) declaration = scopeLookup address heap +lookup :: (Ord address, Ord scope) => Heap scope address value -> address -> Path scope -> Declaration -> Maybe scope +lookup heap address (DPath d) declaration = guard (d == declaration) >> scopeLookup address heap lookup heap address (EPath label scope path) declaration = do frame <- frameLookup address heap scopeMap <- Map.lookup label (links frame) nextAddress <- Map.lookup scope scopeMap lookup heap nextAddress path declaration -newFrame :: (Ord address, Ord declaration) => scope -> address -> Map EdgeLabel (Map scope address) -> Heap scope address declaration value -> Heap scope address declaration value +newFrame :: (Ord address) => scope -> address -> Map EdgeLabel (Map scope address) -> Heap scope address value -> Heap scope address value newFrame scope address links = insertFrame address (Frame scope links mempty) -initFrame :: (Ord address, Ord declaration) => scope -> address -> Map EdgeLabel (Map scope address) -> Map declaration value -> Heap scope address declaration value -> Heap scope address declaration value +initFrame :: (Ord address) => scope -> address -> Map EdgeLabel (Map scope address) -> Map Declaration value -> Heap scope address value -> Heap scope address value initFrame scope address links slots = fillFrame address slots . newFrame scope address links -insertFrame :: Ord address => address -> Frame scope address declaration value -> Heap scope address declaration value -> Heap scope address declaration value +insertFrame :: Ord address => address -> Frame scope address value -> Heap scope address value -> Heap scope address value insertFrame address frame = Heap . Map.insert address frame . unHeap -fillFrame :: Ord address => address -> Map declaration value -> Heap scope address declaration value -> Heap scope address declaration value +fillFrame :: Ord address => address -> Map Declaration value -> Heap scope address value -> Heap scope address value fillFrame address slots heap = case frameLookup address heap of Just frame -> insertFrame address (frame { slots = slots }) heap Nothing -> heap -deleteFrame :: Ord address => address -> Heap scope address declaration value -> Heap scope address declaration value +deleteFrame :: Ord address => address -> Heap scope address value -> Heap scope address value deleteFrame address = Heap . Map.delete address . unHeap -- | The number of frames in the `Heap`. -heapSize :: Heap scope address declaration value -> Int +heapSize :: Heap scope address value -> Int heapSize = Map.size . unHeap -- -- | Look up the list of values stored for a given address, if any. From 4e28c3aa0c2cc9de7e452265b5cae0822557969d Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 18:50:22 -0400 Subject: [PATCH 38/72] Cover all New cases --- src/Data/Syntax/Expression.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 8b31ce818..e01332d29 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -2,7 +2,6 @@ {-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Expression where -import qualified Data.Map.Strict as Map import Control.Abstract.ScopeGraph as ScopeGraph import Data.Abstract.Evaluatable hiding (Member) import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv) @@ -550,9 +549,12 @@ instance Show1 New where liftShowsPrec = genericLiftShowsPrec -- TODO: Implement Eval instance for New instance Evaluatable New where - eval (New [subject]) = do - name <- maybeM (throwEvalError NoNameError) (declaredName (subterm subject)) - reference (Reference name) (Declaration name) + eval New{..} = do + case newSubject of + [] -> pure () + (subject : _) -> do + name <- maybeM (throwEvalError NoNameError) (declaredName (subterm subject)) + reference (Reference name) (Declaration name) -- TODO: Traverse subterms and instantiate frames from the corresponding scope rvalBox unit From 68ca3b06bc5338be571b8ef0529835869acbe0cd Mon Sep 17 00:00:00 2001 From: joshvera Date: Fri, 14 Sep 2018 19:04:09 -0400 Subject: [PATCH 39/72] Remove type-combinators dep --- semantic.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/semantic.cabal b/semantic.cabal index 0c8d1afeb..2a0a33a14 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -264,7 +264,6 @@ library , tree-sitter-ruby , tree-sitter-typescript , tree-sitter-java - , type-combinators default-language: Haskell2010 default-extensions: DataKinds , DeriveFoldable From d38b0998a06c7d551292bd53bb0b2f2d3b621102 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 09:29:27 -0700 Subject: [PATCH 40/72] ++tree-sitter with a few language grammar updates too --- vendor/haskell-tree-sitter | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/haskell-tree-sitter b/vendor/haskell-tree-sitter index 75f9ddd2d..6e120871e 160000 --- a/vendor/haskell-tree-sitter +++ b/vendor/haskell-tree-sitter @@ -1 +1 @@ -Subproject commit 75f9ddd2deb992d944a8485fe9b0cc7c84911c31 +Subproject commit 6e120871e89e65038b4d214b83a0add7e76a4d73 From 31f019cb657d9fd2a94bee1ba3f57d9d85f58f2f Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 09:29:37 -0700 Subject: [PATCH 41/72] Ruby assignment changes to support then --- src/Language/Ruby/Assignment.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs index 6617a2b5f..5226e9552 100644 --- a/src/Language/Ruby/Assignment.hs +++ b/src/Language/Ruby/Assignment.hs @@ -163,6 +163,7 @@ expressionChoices = , heredoc , identifier , if' + , then' , lambda , literal , method @@ -270,7 +271,7 @@ literal = (children (inject . Literal.String <$> some (interpolation <|> escapeSequence)) <|> inject . Literal.TextElement <$> source) symbol' :: Assignment Term - symbol' = makeTerm' <$> (symbol Symbol <|> symbol Symbol' <|> symbol BareSymbol) <*> + symbol' = makeTerm' <$> (symbol Symbol <|> symbol Symbol' <|> symbol Symbol'' <|> symbol BareSymbol) <*> (children (inject . Literal.Symbol <$> some interpolation) <|> inject . Literal.SymbolElement <$> source) interpolation :: Assignment Term @@ -363,14 +364,17 @@ undef = makeTerm <$> symbol Undef <*> children (Expression.Call [] <$> name' <*> where name' = makeTerm <$> location <*> (Syntax.Identifier . name <$> source) if' :: Assignment Term -if' = ifElsif If +if' = ifElsif If <|> makeTerm <$> symbol IfModifier <*> children (flip Statement.If <$> expression <*> expression <*> emptyTerm) where ifElsif s = makeTerm <$> symbol s <*> children (Statement.If <$> expression <*> expressions' <*> (elsif' <|> else' <|> emptyTerm)) - expressions' = makeTerm <$> location <*> manyTermsTill expression (void (symbol Else) <|> void (symbol Elsif) <|> eof) elsif' = postContextualize comment (ifElsif Elsif) + expressions' = makeTerm <$> location <*> manyTermsTill expression (void (symbol Else) <|> void (symbol Elsif) <|> eof) else' = postContextualize comment (symbol Else *> children expressions) +then' :: Assignment Term +then' = postContextualize comment (symbol Then *> children expressions) + unless :: Assignment Term unless = makeTerm <$> symbol Unless <*> children (Statement.If <$> invert expression <*> expressions' <*> (else' <|> emptyTerm)) <|> makeTerm <$> symbol UnlessModifier <*> children (flip Statement.If <$> expression <*> invert expression <*> emptyTerm) @@ -505,17 +509,17 @@ unary = symbol Unary >>= \ location -> <|> makeTerm location . Expression.Not <$> children ( symbol AnonBang *> expression ) <|> makeTerm location . Expression.Not <$> children ( symbol AnonNot *> expression ) <|> makeTerm location <$> children (Expression.Call [] <$> (makeTerm <$> symbol AnonDefinedQuestion <*> (Syntax.Identifier . name <$> source)) <*> some expression <*> emptyTerm) - <|> makeTerm location . Expression.Negate <$> children ( symbol AnonMinus' *> expression ) + <|> makeTerm location . Expression.Negate <$> children ( (symbol AnonMinus <|> symbol AnonMinus' <|> symbol AnonMinus'') *> expression ) <|> children ( symbol AnonPlus *> expression ) -- TODO: Distinguish `===` from `==` ? binary :: Assignment Term binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expression [ (inject .) . Expression.Plus <$ symbol AnonPlus - , (inject .) . Expression.Minus <$ symbol AnonMinus' - , (inject .) . Expression.Times <$ symbol AnonStar' + , (inject .) . Expression.Minus <$ (symbol AnonMinus <|> symbol AnonMinus' <|> symbol AnonMinus'') + , (inject .) . Expression.Times <$ (symbol AnonStar <|> symbol AnonStar') , (inject .) . Expression.Power <$ symbol AnonStarStar - , (inject .) . Expression.DividedBy <$ symbol AnonSlash + , (inject .) . Expression.DividedBy <$ (symbol AnonSlash <|> symbol AnonSlash' <|> symbol AnonSlash'') , (inject .) . Expression.Modulo <$ symbol AnonPercent , (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand , (inject .) . Ruby.Syntax.LowPrecedenceAnd <$ symbol AnonAnd @@ -530,7 +534,7 @@ binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expressi -- for this situation. , (inject .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual) , (inject .) . invert Expression.Equal <$ symbol AnonBangEqual - , (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle + , (inject .) . Expression.LShift <$ (symbol AnonLAngleLAngle <|> symbol AnonLAngleLAngle') , (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle , (inject .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle , (inject .) . Expression.LessThan <$ symbol AnonLAngle From 80dfd75635416a8521c2f9cb4f7304f3de6f1e4c Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 09:30:03 -0700 Subject: [PATCH 42/72] Ruby corpus changes --- test/fixtures/ruby/corpus/if.diffA-B.txt | 3 +- test/fixtures/ruby/corpus/if.diffB-A.txt | 3 +- test/fixtures/ruby/corpus/if.parseB.txt | 3 +- test/fixtures/ruby/corpus/unless.diffA-B.txt | 3 +- test/fixtures/ruby/corpus/unless.diffB-A.txt | 3 +- test/fixtures/ruby/corpus/unless.parseB.txt | 3 +- test/fixtures/ruby/corpus/when-else.B.rb | 2 + .../ruby/corpus/when-else.diffA-B.txt | 38 ++++++++++++------- .../ruby/corpus/when-else.diffB-A.txt | 35 ++++++++++------- .../fixtures/ruby/corpus/when-else.parseA.txt | 20 +++++----- .../fixtures/ruby/corpus/when-else.parseB.txt | 14 ++++++- test/fixtures/ruby/corpus/when.diffA-B.txt | 18 ++++----- test/fixtures/ruby/corpus/when.diffB-A.txt | 18 ++++----- test/fixtures/ruby/corpus/when.parseB.txt | 18 ++++----- 14 files changed, 108 insertions(+), 73 deletions(-) diff --git a/test/fixtures/ruby/corpus/if.diffA-B.txt b/test/fixtures/ruby/corpus/if.diffA-B.txt index ee09c8179..7c4319294 100644 --- a/test/fixtures/ruby/corpus/if.diffA-B.txt +++ b/test/fixtures/ruby/corpus/if.diffA-B.txt @@ -18,5 +18,6 @@ {+(If {+(Send {+(Identifier)+})+} - {+(Statements)+} + {+(Statements + {+(Statements)+})+} {+(Empty)+})+}) diff --git a/test/fixtures/ruby/corpus/if.diffB-A.txt b/test/fixtures/ruby/corpus/if.diffB-A.txt index 68c2a1709..0c1552787 100644 --- a/test/fixtures/ruby/corpus/if.diffB-A.txt +++ b/test/fixtures/ruby/corpus/if.diffB-A.txt @@ -18,5 +18,6 @@ {-(If {-(Send {-(Identifier)-})-} - {-(Statements)-} + {-(Statements + {-(Statements)-})-} {-(Empty)-})-}) diff --git a/test/fixtures/ruby/corpus/if.parseB.txt b/test/fixtures/ruby/corpus/if.parseB.txt index ff39ff4e3..e0e74289d 100644 --- a/test/fixtures/ruby/corpus/if.parseB.txt +++ b/test/fixtures/ruby/corpus/if.parseB.txt @@ -7,5 +7,6 @@ (If (Send (Identifier)) - (Statements) + (Statements + (Statements)) (Empty))) diff --git a/test/fixtures/ruby/corpus/unless.diffA-B.txt b/test/fixtures/ruby/corpus/unless.diffA-B.txt index 5097e8529..de578d6d3 100644 --- a/test/fixtures/ruby/corpus/unless.diffA-B.txt +++ b/test/fixtures/ruby/corpus/unless.diffA-B.txt @@ -14,5 +14,6 @@ {+(Not {+(Send {+(Identifier)+})+})+} - {+(Statements)+} + {+(Statements + {+(Statements)+})+} {+(Empty)+})+}) diff --git a/test/fixtures/ruby/corpus/unless.diffB-A.txt b/test/fixtures/ruby/corpus/unless.diffB-A.txt index 9b84c28f8..1436f1792 100644 --- a/test/fixtures/ruby/corpus/unless.diffB-A.txt +++ b/test/fixtures/ruby/corpus/unless.diffB-A.txt @@ -14,5 +14,6 @@ {-(Not {-(Send {-(Identifier)-})-})-} - {-(Statements)-} + {-(Statements + {-(Statements)-})-} {-(Empty)-})-}) diff --git a/test/fixtures/ruby/corpus/unless.parseB.txt b/test/fixtures/ruby/corpus/unless.parseB.txt index 9662e1fab..15fe52639 100644 --- a/test/fixtures/ruby/corpus/unless.parseB.txt +++ b/test/fixtures/ruby/corpus/unless.parseB.txt @@ -9,5 +9,6 @@ (Not (Send (Identifier))) - (Statements) + (Statements + (Statements)) (Empty))) diff --git a/test/fixtures/ruby/corpus/when-else.B.rb b/test/fixtures/ruby/corpus/when-else.B.rb index 028bb595f..e0cb03e92 100644 --- a/test/fixtures/ruby/corpus/when-else.B.rb +++ b/test/fixtures/ruby/corpus/when-else.B.rb @@ -1,6 +1,8 @@ case foo when bar baz +when x +when y else qoz end diff --git a/test/fixtures/ruby/corpus/when-else.diffA-B.txt b/test/fixtures/ruby/corpus/when-else.diffA-B.txt index 08579b880..9aa7e9f78 100644 --- a/test/fixtures/ruby/corpus/when-else.diffA-B.txt +++ b/test/fixtures/ruby/corpus/when-else.diffA-B.txt @@ -3,23 +3,33 @@ (Send (Identifier)) (Statements + {+(Pattern + {+(Statements + {+(Send + {+(Identifier)+})+})+} + {+(Statements + {+(Send + {+(Identifier)+})+})+})+} (Pattern (Statements (Send { (Identifier) ->(Identifier) })) - (Statements + (Statements)) + {+(Pattern + {+(Statements {+(Send - {+(Identifier)+})+} - {+(Send - {+(Identifier)+})+} - {-(Pattern - {-(Statements - {-(Send - {-(Identifier)-})-} - {-(Send - {-(Identifier)-})-})-} - {-(Statements - {-(Send - {-(Identifier)-})-} - {-(Statements)-})-})-}))))) + {+(Identifier)+})+})+} + {+(Statements)+})+} + {+(Send + {+(Identifier)+})+} + {-(Pattern + {-(Statements + {-(Send + {-(Identifier)-})-} + {-(Send + {-(Identifier)-})-})-} + {-(Statements + {-(Send + {-(Identifier)-})-})-})-} + {-(Statements)-}))) diff --git a/test/fixtures/ruby/corpus/when-else.diffB-A.txt b/test/fixtures/ruby/corpus/when-else.diffB-A.txt index b130388e8..bb9a453d8 100644 --- a/test/fixtures/ruby/corpus/when-else.diffB-A.txt +++ b/test/fixtures/ruby/corpus/when-else.diffB-A.txt @@ -3,23 +3,30 @@ (Send (Identifier)) (Statements + {+(Pattern + {+(Statements + {+(Send + {+(Identifier)+})+})+} + {+(Statements)+})+} (Pattern (Statements (Send - { (Identifier) - ->(Identifier) })) + (Identifier)) + {+(Send + {+(Identifier)+})+}) (Statements - {+(Pattern - {+(Statements - {+(Send - {+(Identifier)+})+} - {+(Send - {+(Identifier)+})+})+} - {+(Statements - {+(Send - {+(Identifier)+})+} - {+(Statements)+})+})+} + (Send + (Identifier)))) + {+(Statements)+} + {-(Pattern + {-(Statements {-(Send - {-(Identifier)-})-} + {-(Identifier)-})-})-} + {-(Statements)-})-} + {-(Pattern + {-(Statements {-(Send - {-(Identifier)-})-}))))) + {-(Identifier)-})-})-} + {-(Statements)-})-} + {-(Send + {-(Identifier)-})-}))) diff --git a/test/fixtures/ruby/corpus/when-else.parseA.txt b/test/fixtures/ruby/corpus/when-else.parseA.txt index e782e5233..4ad38cef0 100644 --- a/test/fixtures/ruby/corpus/when-else.parseA.txt +++ b/test/fixtures/ruby/corpus/when-else.parseA.txt @@ -7,14 +7,14 @@ (Statements (Send (Identifier))) + (Statements)) + (Pattern (Statements - (Pattern - (Statements - (Send - (Identifier)) - (Send - (Identifier))) - (Statements - (Send - (Identifier)) - (Statements)))))))) + (Send + (Identifier)) + (Send + (Identifier))) + (Statements + (Send + (Identifier)))) + (Statements)))) diff --git a/test/fixtures/ruby/corpus/when-else.parseB.txt b/test/fixtures/ruby/corpus/when-else.parseB.txt index d01cc541f..f813939bb 100644 --- a/test/fixtures/ruby/corpus/when-else.parseB.txt +++ b/test/fixtures/ruby/corpus/when-else.parseB.txt @@ -9,6 +9,16 @@ (Identifier))) (Statements (Send - (Identifier)) + (Identifier)))) + (Pattern + (Statements (Send - (Identifier))))))) + (Identifier))) + (Statements)) + (Pattern + (Statements + (Send + (Identifier))) + (Statements)) + (Send + (Identifier))))) diff --git a/test/fixtures/ruby/corpus/when.diffA-B.txt b/test/fixtures/ruby/corpus/when.diffA-B.txt index e9b501002..cfc1de620 100644 --- a/test/fixtures/ruby/corpus/when.diffA-B.txt +++ b/test/fixtures/ruby/corpus/when.diffA-B.txt @@ -8,17 +8,17 @@ (Send (Identifier))) (Statements + {+(Send + {+(Identifier)+})+})) + {+(Pattern + {+(Statements {+(Send {+(Identifier)+})+} - {+(Pattern - {+(Statements - {+(Send - {+(Identifier)+})+} - {+(Send - {+(Identifier)+})+})+} - {+(Statements - {+(Send - {+(Identifier)+})+})+})+})))) + {+(Send + {+(Identifier)+})+})+} + {+(Statements)+})+} + {+(Send + {+(Identifier)+})+})) {-(Match {-(Empty)-} {-(Statements diff --git a/test/fixtures/ruby/corpus/when.diffB-A.txt b/test/fixtures/ruby/corpus/when.diffB-A.txt index 7d2880cc0..ec07279c8 100644 --- a/test/fixtures/ruby/corpus/when.diffB-A.txt +++ b/test/fixtures/ruby/corpus/when.diffB-A.txt @@ -8,17 +8,17 @@ (Send (Identifier))) (Statements + {-(Send + {-(Identifier)-})-})) + {-(Pattern + {-(Statements {-(Send {-(Identifier)-})-} - {-(Pattern - {-(Statements - {-(Send - {-(Identifier)-})-} - {-(Send - {-(Identifier)-})-})-} - {-(Statements - {-(Send - {-(Identifier)-})-})-})-})))) + {-(Send + {-(Identifier)-})-})-} + {-(Statements)-})-} + {-(Send + {-(Identifier)-})-})) {+(Match {+(Empty)+} {+(Statements diff --git a/test/fixtures/ruby/corpus/when.parseB.txt b/test/fixtures/ruby/corpus/when.parseB.txt index 3c54f2901..2144c5a90 100644 --- a/test/fixtures/ruby/corpus/when.parseB.txt +++ b/test/fixtures/ruby/corpus/when.parseB.txt @@ -7,15 +7,15 @@ (Statements (Send (Identifier))) + (Statements + (Send + (Identifier)))) + (Pattern (Statements (Send (Identifier)) - (Pattern - (Statements - (Send - (Identifier)) - (Send - (Identifier))) - (Statements - (Send - (Identifier))))))))) + (Send + (Identifier))) + (Statements)) + (Send + (Identifier))))) From e8298a6e1eac6a5e9f1258049ab97b739d66b090 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 09:30:13 -0700 Subject: [PATCH 43/72] TypeScript Identifier'' --- src/Language/TypeScript/Assignment.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index 2b40e195b..de6c58818 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -382,7 +382,7 @@ false :: Assignment Term false = makeTerm <$> symbol Grammar.False <*> (Literal.false <$ rawSource) identifier :: Assignment Term -identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier') <*> (Syntax.Identifier . name <$> source) +identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') <*> (Syntax.Identifier . name <$> source) class' :: Assignment Term class' = makeClass <$> symbol Class <*> children ((,,,,) <$> manyTerm decorator <*> term typeIdentifier <*> (symbol TypeParameters *> children (manyTerm typeParameter') <|> pure []) <*> (classHeritage' <|> pure []) <*> classBodyStatements) @@ -725,7 +725,7 @@ importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> childr makeImportTerm loc ([x], from) = makeImportTerm1 loc from x makeImportTerm loc (xs, from) = makeTerm loc $ fmap (makeImportTerm1 loc from) xs importSymbol = symbol Grammar.ImportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> ((Just <$> rawIdentifier) <|> pure Nothing)) - rawIdentifier = (symbol Identifier <|> symbol Identifier') *> (name <$> source) + rawIdentifier = (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> (name <$> source) makeNameAliasPair from (Just alias) = (from, alias) makeNameAliasPair from Nothing = (from, from) @@ -784,7 +784,7 @@ exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip <|> symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> pure Nothing) makeNameAliasPair from (Just alias) = TypeScript.Syntax.Alias from alias makeNameAliasPair from Nothing = TypeScript.Syntax.Alias from from - rawIdentifier = (symbol Identifier <|> symbol Identifier') *> (name <$> source) + rawIdentifier = (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> (name <$> source) -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term. fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source) @@ -860,7 +860,7 @@ variableDeclarator = where makeVarDecl loc (subject, annotations, value) = makeTerm loc (Statement.Assignment [annotations] subject value) - requireCall = symbol CallExpression *> children ((symbol Identifier <|> symbol Identifier') *> do + requireCall = symbol CallExpression *> children ((symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> do s <- source guard (s == "require") symbol Arguments *> children (symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source)) From 883d4586c0a09cabf7cd9706823f19c39a51627f Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 09:48:47 -0700 Subject: [PATCH 44/72] TypeScript fixes for more type identifiers --- src/Language/TypeScript/Assignment.hs | 4 ++-- test/fixtures/typescript/corpus/class.diffA-B.txt | 4 ++-- test/fixtures/typescript/corpus/class.diffB-A.txt | 4 ++-- test/fixtures/typescript/corpus/class.parseA.txt | 2 +- test/fixtures/typescript/corpus/class.parseB.txt | 2 +- test/fixtures/typescript/corpus/function.diffA-B.txt | 2 +- test/fixtures/typescript/corpus/function.diffB-A.txt | 2 +- test/fixtures/typescript/corpus/function.parseA.txt | 2 +- test/fixtures/typescript/corpus/interface.diffA-B.txt | 2 +- test/fixtures/typescript/corpus/interface.diffB-A.txt | 2 +- test/fixtures/typescript/corpus/interface.parseA.txt | 2 +- 11 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index de6c58818..a72f9fb52 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -515,7 +515,7 @@ typeAnnotation' :: Assignment Term typeAnnotation' = makeTerm <$> symbol TypeAnnotation <*> children (TypeScript.Syntax.Annotation <$> term ty) typeParameter' :: Assignment Term -typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TypeScript.Syntax.TypeParameter <$> term identifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm)) +typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TypeScript.Syntax.TypeParameter <$> term typeIdentifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm)) defaultType :: Assignment Term defaultType = makeTerm <$> symbol Grammar.DefaultType <*> children (TypeScript.Syntax.DefaultType <$> term ty) @@ -593,7 +593,7 @@ typeQuery :: Assignment Term typeQuery = makeTerm <$> symbol Grammar.TypeQuery <*> children (TypeScript.Syntax.TypeQuery <$> term (identifier <|> nestedIdentifier)) indexTypeQuery :: Assignment Term -indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TypeScript.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedIdentifier)) +indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TypeScript.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedTypeIdentifier)) thisType :: Assignment Term thisType = makeTerm <$> symbol Grammar.ThisType <*> (TypeScript.Syntax.ThisType <$> source) diff --git a/test/fixtures/typescript/corpus/class.diffA-B.txt b/test/fixtures/typescript/corpus/class.diffA-B.txt index 29879240f..5c98bcf04 100644 --- a/test/fixtures/typescript/corpus/class.diffA-B.txt +++ b/test/fixtures/typescript/corpus/class.diffA-B.txt @@ -1,8 +1,8 @@ (Statements (Class (TypeParameter - { (Identifier) - ->(Identifier) } + { (TypeIdentifier) + ->(TypeIdentifier) } (Empty) (Empty)) { (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/class.diffB-A.txt b/test/fixtures/typescript/corpus/class.diffB-A.txt index 926e88625..153584c01 100644 --- a/test/fixtures/typescript/corpus/class.diffB-A.txt +++ b/test/fixtures/typescript/corpus/class.diffB-A.txt @@ -1,8 +1,8 @@ (Statements (Class (TypeParameter - { (Identifier) - ->(Identifier) } + { (TypeIdentifier) + ->(TypeIdentifier) } (Empty) (Empty)) { (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/class.parseA.txt b/test/fixtures/typescript/corpus/class.parseA.txt index c6cec68e4..4747bd525 100644 --- a/test/fixtures/typescript/corpus/class.parseA.txt +++ b/test/fixtures/typescript/corpus/class.parseA.txt @@ -1,7 +1,7 @@ (Statements (Class (TypeParameter - (Identifier) + (TypeIdentifier) (Empty) (Empty)) (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/class.parseB.txt b/test/fixtures/typescript/corpus/class.parseB.txt index 9a7ad3a5b..e5b62e6b9 100644 --- a/test/fixtures/typescript/corpus/class.parseB.txt +++ b/test/fixtures/typescript/corpus/class.parseB.txt @@ -1,7 +1,7 @@ (Statements (Class (TypeParameter - (Identifier) + (TypeIdentifier) (Empty) (Empty)) (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/function.diffA-B.txt b/test/fixtures/typescript/corpus/function.diffA-B.txt index 5c54f63d9..5e05038d2 100644 --- a/test/fixtures/typescript/corpus/function.diffA-B.txt +++ b/test/fixtures/typescript/corpus/function.diffA-B.txt @@ -5,7 +5,7 @@ {+(TypeIdentifier)+})+} {-(TypeParameters {-(TypeParameter - {-(Identifier)-} + {-(TypeIdentifier)-} {-(Empty)-} {-(Empty)-})-})-} {-(Annotation diff --git a/test/fixtures/typescript/corpus/function.diffB-A.txt b/test/fixtures/typescript/corpus/function.diffB-A.txt index 7a9134389..57a351ac8 100644 --- a/test/fixtures/typescript/corpus/function.diffB-A.txt +++ b/test/fixtures/typescript/corpus/function.diffB-A.txt @@ -2,7 +2,7 @@ (Function {+(TypeParameters {+(TypeParameter - {+(Identifier)+} + {+(TypeIdentifier)+} {+(Empty)+} {+(Empty)+})+})+} {+(Annotation diff --git a/test/fixtures/typescript/corpus/function.parseA.txt b/test/fixtures/typescript/corpus/function.parseA.txt index c50656cda..db85ab16c 100644 --- a/test/fixtures/typescript/corpus/function.parseA.txt +++ b/test/fixtures/typescript/corpus/function.parseA.txt @@ -2,7 +2,7 @@ (Function (TypeParameters (TypeParameter - (Identifier) + (TypeIdentifier) (Empty) (Empty))) (Annotation diff --git a/test/fixtures/typescript/corpus/interface.diffA-B.txt b/test/fixtures/typescript/corpus/interface.diffA-B.txt index 6a32ceab7..611ad4d1e 100644 --- a/test/fixtures/typescript/corpus/interface.diffA-B.txt +++ b/test/fixtures/typescript/corpus/interface.diffA-B.txt @@ -3,7 +3,7 @@ {+(Empty)+} {-(TypeParameters {-(TypeParameter - {-(Identifier)-} + {-(TypeIdentifier)-} {-(Empty)-} {-(Empty)-})-})-} { (TypeIdentifier) diff --git a/test/fixtures/typescript/corpus/interface.diffB-A.txt b/test/fixtures/typescript/corpus/interface.diffB-A.txt index 642cc7eab..e7d262f88 100644 --- a/test/fixtures/typescript/corpus/interface.diffB-A.txt +++ b/test/fixtures/typescript/corpus/interface.diffB-A.txt @@ -2,7 +2,7 @@ (InterfaceDeclaration {+(TypeParameters {+(TypeParameter - {+(Identifier)+} + {+(TypeIdentifier)+} {+(Empty)+} {+(Empty)+})+})+} {-(Empty)-} diff --git a/test/fixtures/typescript/corpus/interface.parseA.txt b/test/fixtures/typescript/corpus/interface.parseA.txt index 1b6b96deb..99f663d59 100644 --- a/test/fixtures/typescript/corpus/interface.parseA.txt +++ b/test/fixtures/typescript/corpus/interface.parseA.txt @@ -2,7 +2,7 @@ (InterfaceDeclaration (TypeParameters (TypeParameter - (Identifier) + (TypeIdentifier) (Empty) (Empty))) (TypeIdentifier) From c97d43aaca33182a489a528025560972cc926146 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 09:56:31 -0700 Subject: [PATCH 45/72] Refinement of types is Go --- .../go/corpus/method-declarations.diffA-B.txt | 5 ++-- .../go/corpus/method-declarations.diffB-A.txt | 5 ++-- .../go/corpus/method-declarations.parseA.txt | 5 ++-- .../go/corpus/method-declarations.parseB.txt | 5 ++-- .../go/corpus/select-statements.diffA-B.txt | 5 ++-- .../go/corpus/select-statements.diffB-A.txt | 5 ++-- .../go/corpus/select-statements.parseA.txt | 5 ++-- .../go/corpus/select-statements.parseB.txt | 5 ++-- .../type-conversion-expressions.diffA-B.txt | 30 +++++++++---------- .../type-conversion-expressions.diffB-A.txt | 30 +++++++++---------- .../type-conversion-expressions.parseA.txt | 15 +++++----- .../type-conversion-expressions.parseB.txt | 15 +++++----- 12 files changed, 58 insertions(+), 72 deletions(-) diff --git a/test/fixtures/go/corpus/method-declarations.diffA-B.txt b/test/fixtures/go/corpus/method-declarations.diffA-B.txt index 66222ddb2..f7e35e0e0 100644 --- a/test/fixtures/go/corpus/method-declarations.diffA-B.txt +++ b/test/fixtures/go/corpus/method-declarations.diffA-B.txt @@ -31,7 +31,7 @@ { (Identifier) ->(Identifier) } (Return - (Call + (TypeConversion (MemberAccess (Identifier)) (Plus @@ -66,8 +66,7 @@ {-(MemberAccess {-(Identifier)-})-}) ->(MemberAccess - {+(Identifier)+}) }) - (Empty)))) + {+(Identifier)+}) })))) (Method (Statements (Assignment diff --git a/test/fixtures/go/corpus/method-declarations.diffB-A.txt b/test/fixtures/go/corpus/method-declarations.diffB-A.txt index 7e5b0207f..f1ca6156d 100644 --- a/test/fixtures/go/corpus/method-declarations.diffB-A.txt +++ b/test/fixtures/go/corpus/method-declarations.diffB-A.txt @@ -31,7 +31,7 @@ { (Identifier) ->(Identifier) } (Return - (Call + (TypeConversion (MemberAccess (Identifier)) (Plus @@ -66,8 +66,7 @@ {+(MemberAccess {+(Identifier)+})+} {+(MemberAccess - {+(Identifier)+})+}) }) - (Empty)))) + {+(Identifier)+})+}) })))) (Method (Statements (Assignment diff --git a/test/fixtures/go/corpus/method-declarations.parseA.txt b/test/fixtures/go/corpus/method-declarations.parseA.txt index 9ef9be5de..a2493d1b8 100644 --- a/test/fixtures/go/corpus/method-declarations.parseA.txt +++ b/test/fixtures/go/corpus/method-declarations.parseA.txt @@ -27,7 +27,7 @@ (Identifier))) (Identifier) (Return - (Call + (TypeConversion (MemberAccess (Identifier)) (Plus @@ -40,8 +40,7 @@ (MemberAccess (Identifier)) (MemberAccess - (Identifier)))) - (Empty)))) + (Identifier))))))) (Method (Statements (Assignment diff --git a/test/fixtures/go/corpus/method-declarations.parseB.txt b/test/fixtures/go/corpus/method-declarations.parseB.txt index d7bcc40f9..3728c63e9 100644 --- a/test/fixtures/go/corpus/method-declarations.parseB.txt +++ b/test/fixtures/go/corpus/method-declarations.parseB.txt @@ -27,7 +27,7 @@ (Identifier))) (Identifier) (Return - (Call + (TypeConversion (MemberAccess (Identifier)) (Plus @@ -52,8 +52,7 @@ (Integer)) (Empty))) (MemberAccess - (Identifier))) - (Empty)))) + (Identifier)))))) (Method (Statements (Assignment diff --git a/test/fixtures/go/corpus/select-statements.diffA-B.txt b/test/fixtures/go/corpus/select-statements.diffA-B.txt index a2c5e9747..e0b487368 100644 --- a/test/fixtures/go/corpus/select-statements.diffA-B.txt +++ b/test/fixtures/go/corpus/select-statements.diffA-B.txt @@ -29,12 +29,11 @@ (Receive (Empty) (ReceiveOperator - (Call + (TypeConversion (MemberAccess (Identifier)) { (Integer) - ->(Integer) } - (Empty)))) + ->(Integer) }))) (Statements (Call (Identifier) diff --git a/test/fixtures/go/corpus/select-statements.diffB-A.txt b/test/fixtures/go/corpus/select-statements.diffB-A.txt index dbed25d39..e0ecbbe22 100644 --- a/test/fixtures/go/corpus/select-statements.diffB-A.txt +++ b/test/fixtures/go/corpus/select-statements.diffB-A.txt @@ -29,12 +29,11 @@ (Receive (Empty) (ReceiveOperator - (Call + (TypeConversion (MemberAccess (Identifier)) { (Integer) - ->(Integer) } - (Empty)))) + ->(Integer) }))) (Statements (Call (Identifier) diff --git a/test/fixtures/go/corpus/select-statements.parseA.txt b/test/fixtures/go/corpus/select-statements.parseA.txt index df226d396..d73079a32 100644 --- a/test/fixtures/go/corpus/select-statements.parseA.txt +++ b/test/fixtures/go/corpus/select-statements.parseA.txt @@ -27,11 +27,10 @@ (Receive (Empty) (ReceiveOperator - (Call + (TypeConversion (MemberAccess (Identifier)) - (Integer) - (Empty)))) + (Integer)))) (Statements (Call (Identifier) diff --git a/test/fixtures/go/corpus/select-statements.parseB.txt b/test/fixtures/go/corpus/select-statements.parseB.txt index c20a51893..339b089ac 100644 --- a/test/fixtures/go/corpus/select-statements.parseB.txt +++ b/test/fixtures/go/corpus/select-statements.parseB.txt @@ -27,11 +27,10 @@ (Receive (Empty) (ReceiveOperator - (Call + (TypeConversion (MemberAccess (Identifier)) - (Integer) - (Empty)))) + (Integer)))) (Statements (Call (Identifier) diff --git a/test/fixtures/go/corpus/type-conversion-expressions.diffA-B.txt b/test/fixtures/go/corpus/type-conversion-expressions.diffA-B.txt index eb3323ad2..c723523a0 100644 --- a/test/fixtures/go/corpus/type-conversion-expressions.diffA-B.txt +++ b/test/fixtures/go/corpus/type-conversion-expressions.diffA-B.txt @@ -70,23 +70,21 @@ {-(Identifier)-}) ->(MemberAccess {+(Identifier)+}) }) - {+(Call + {+(TypeConversion {+(MemberAccess {+(Identifier)+})+} - {+(Identifier)+} - {+(Empty)+})+} - {+(Call - {+(MemberAccess - {+(Identifier)+})+} - {+(Identifier)+} - {+(Empty)+})+} - {-(Call + {+(Identifier)+})+} + {+(TypeConversion + {+(Parenthesized + {+(MemberAccess + {+(Identifier)+})+})+} + {+(Identifier)+})+} + {-(TypeConversion {-(MemberAccess {-(Identifier)-})-} - {-(Identifier)-} - {-(Empty)-})-} - {-(Call - {-(MemberAccess - {-(Identifier)-})-} - {-(Identifier)-} - {-(Empty)-})-}))) + {-(Identifier)-})-} + {-(TypeConversion + {-(Parenthesized + {-(MemberAccess + {-(Identifier)-})-})-} + {-(Identifier)-})-}))) diff --git a/test/fixtures/go/corpus/type-conversion-expressions.diffB-A.txt b/test/fixtures/go/corpus/type-conversion-expressions.diffB-A.txt index eb3323ad2..c723523a0 100644 --- a/test/fixtures/go/corpus/type-conversion-expressions.diffB-A.txt +++ b/test/fixtures/go/corpus/type-conversion-expressions.diffB-A.txt @@ -70,23 +70,21 @@ {-(Identifier)-}) ->(MemberAccess {+(Identifier)+}) }) - {+(Call + {+(TypeConversion {+(MemberAccess {+(Identifier)+})+} - {+(Identifier)+} - {+(Empty)+})+} - {+(Call - {+(MemberAccess - {+(Identifier)+})+} - {+(Identifier)+} - {+(Empty)+})+} - {-(Call + {+(Identifier)+})+} + {+(TypeConversion + {+(Parenthesized + {+(MemberAccess + {+(Identifier)+})+})+} + {+(Identifier)+})+} + {-(TypeConversion {-(MemberAccess {-(Identifier)-})-} - {-(Identifier)-} - {-(Empty)-})-} - {-(Call - {-(MemberAccess - {-(Identifier)-})-} - {-(Identifier)-} - {-(Empty)-})-}))) + {-(Identifier)-})-} + {-(TypeConversion + {-(Parenthesized + {-(MemberAccess + {-(Identifier)-})-})-} + {-(Identifier)-})-}))) diff --git a/test/fixtures/go/corpus/type-conversion-expressions.parseA.txt b/test/fixtures/go/corpus/type-conversion-expressions.parseA.txt index 783917ac3..4d01c1fb1 100644 --- a/test/fixtures/go/corpus/type-conversion-expressions.parseA.txt +++ b/test/fixtures/go/corpus/type-conversion-expressions.parseA.txt @@ -54,13 +54,12 @@ (Identifier)))) (MemberAccess (Identifier))) - (Call + (TypeConversion (MemberAccess (Identifier)) - (Identifier) - (Empty)) - (Call - (MemberAccess - (Identifier)) - (Identifier) - (Empty))))) + (Identifier)) + (TypeConversion + (Parenthesized + (MemberAccess + (Identifier))) + (Identifier))))) diff --git a/test/fixtures/go/corpus/type-conversion-expressions.parseB.txt b/test/fixtures/go/corpus/type-conversion-expressions.parseB.txt index 783917ac3..4d01c1fb1 100644 --- a/test/fixtures/go/corpus/type-conversion-expressions.parseB.txt +++ b/test/fixtures/go/corpus/type-conversion-expressions.parseB.txt @@ -54,13 +54,12 @@ (Identifier)))) (MemberAccess (Identifier))) - (Call + (TypeConversion (MemberAccess (Identifier)) - (Identifier) - (Empty)) - (Call - (MemberAccess - (Identifier)) - (Identifier) - (Empty))))) + (Identifier)) + (TypeConversion + (Parenthesized + (MemberAccess + (Identifier))) + (Identifier))))) From 64c9d208262b76c4b6f69270365325ebaec572cc Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 09:56:39 -0700 Subject: [PATCH 46/72] Error span changed --- test/Rendering/TOC/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index cad8fc354..dab59f3f4 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/test/Rendering/TOC/Spec.hs @@ -152,7 +152,7 @@ spec = parallel $ do it "produces JSON output if there are parse errors" $ do blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.X.rb") output <- runTaskWithOptions (defaultOptions { optionsLogLevel = Nothing }) (runDiff ToCDiffRenderer [blobs]) - runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString) + runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,3]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString) it "ignores anonymous functions" $ do blobs <- blobsForPaths (both "ruby/toc/lambda.A.rb" "ruby/toc/lambda.B.rb") From 2d071e50905e988124322deda3388dac07bfcbe6 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 17 Sep 2018 13:05:24 -0400 Subject: [PATCH 47/72] Remove Data.Abstract.Frame for now --- semantic.cabal | 1 - src/Data/Abstract/Frame.hs | 9 --------- 2 files changed, 10 deletions(-) delete mode 100644 src/Data/Abstract/Frame.hs diff --git a/semantic.cabal b/semantic.cabal index 4a0d6cce2..7c6847e7b 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -63,7 +63,6 @@ library , Data.Abstract.Exports , Data.Abstract.FreeVariables , Data.Abstract.Heap - , Data.Abstract.Frame , Data.Abstract.Live , Data.Abstract.Module , Data.Abstract.ModuleTable diff --git a/src/Data/Abstract/Frame.hs b/src/Data/Abstract/Frame.hs deleted file mode 100644 index 7ab14b247..000000000 --- a/src/Data/Abstract/Frame.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Data.Abstract.Frame () where - - --- setSlot :: t -> value t heap -> Frame s scopes -> Heap scopes -> Heap scopes --- setSlot d v f h = case lookup h f of --- Just (slots, links) -> - --- data Frame types scopes where --- Frame :: Slots types scopes -> Links types scopes -> Frame types scopes From 7e33afef4fa8cf7face2a6be737994db5b46c8a2 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 17 Sep 2018 13:15:20 -0400 Subject: [PATCH 48/72] Remove comments --- src/Data/Abstract/ScopeGraph.hs | 31 ------------------------------- 1 file changed, 31 deletions(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 33a5c2a8e..7c06df877 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -239,34 +239,3 @@ deleteFrame address = Heap . Map.delete address . unHeap -- | The number of frames in the `Heap`. heapSize :: Heap scope address value -> Int heapSize = Map.size . unHeap - --- -- | Look up the list of values stored for a given address, if any. --- scopeLookupAll :: Ord address => address -> Heap address value -> Maybe [value] --- scopeLookupAll address = fmap toList . scopeLookup address - --- -- | Append a value onto the cell for a given address, inserting a new cell if none existed. --- scopeInsert :: (Ord address, Ord value) => address -> value -> Scope address value -> Scope address value --- scopeInsert address value = flip snoc (address, value) - --- -- | Manually insert a cell into the scope at a given address. --- scopeInit :: Ord address => address -> Set value -> Scope address value -> Scope address value --- scopeInit address cell (Scope h) = Scope (Map.insert address cell h) - --- -- | The number of addresses extant in a 'Scope'. --- scopeSize :: Scope address value -> Int --- scopeSize = Map.size . unScope - --- -- | Restrict a 'Scope' to only those addresses in the given 'Live' set (in essence garbage collecting the rest). --- scopeRestrict :: Ord address => Scope address value -> Live address -> Scope address value --- scopeRestrict (Scope m) roots = Scope (Map.filterWithKey (\ address _ -> address `liveMember` roots) m) - --- scopeDelete :: Ord address => address -> Scope address value -> Scope address value --- scopeDelete addr = Scope . Map.delete addr . unScope - --- instance (Ord address, Ord value) => Reducer (address, value) (Scope address value) where --- unit = Scope . unit --- cons (addr, a) (Scope scope) = Scope (cons (addr, a) scope) --- snoc (Scope scope) (addr, a) = Scope (snoc scope (addr, a)) - --- instance (Show address, Show value) => Show (Scope address value) where --- showsPrec d = showsUnaryWith showsPrec "Scope" d . map (second toList) . Map.pairs . unScope From 659c51305fac1529b7fd4c0d58776d2f6f7d8f65 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 17 Sep 2018 13:28:50 -0400 Subject: [PATCH 49/72] remove comment --- src/Data/Syntax/Declaration.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index b4d02b158..7897d89c7 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -131,7 +131,7 @@ instance Evaluatable VariableDeclaration where addresses <- for decs $ \declaration -> do name <- maybeM (throwEvalError NoNameError) (declaredName (subterm declaration)) (span, valueRef) <- do - ref <- subtermRef declaration -- (Assignment [Empty] Identifier Val) + ref <- subtermRef declaration subtermSpan <- get @Span pure (subtermSpan, ref) From 82b6b7c52e633928d73ec57426b3756ca4e18ad0 Mon Sep 17 00:00:00 2001 From: joshvera Date: Mon, 17 Sep 2018 13:29:50 -0400 Subject: [PATCH 50/72] Don't construct new scopes for every local assignment Only construct a new scope for a local assignment if its rhs has an associated scope. --- src/Data/Syntax/Statement.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 5cd8330d1..bf7135db5 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -146,9 +146,11 @@ instance Evaluatable Assignment where case declaredName (subterm assignmentValue) of Just rhsName -> do assocScope <- associatedScope (Declaration rhsName) - let edges = maybe mempty (Map.singleton I . pure) assocScope - objectScope <- newScope edges - putDeclarationScope (Declaration name) objectScope + case assocScope of + Just assocScope' -> do + objectScope <- newScope (Map.singleton I [ assocScope' ]) + putDeclarationScope (Declaration name) objectScope + Nothing -> pure () Nothing -> -- The rhs wasn't assigned to a reference/declaration. pure () From b6e257c088b6cba0bb45f1908474ea6384b67ac0 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 11:22:12 -0700 Subject: [PATCH 51/72] Pick up tree-sitter-go-bump --- vendor/haskell-tree-sitter | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/haskell-tree-sitter b/vendor/haskell-tree-sitter index 6e120871e..6465254c6 160000 --- a/vendor/haskell-tree-sitter +++ b/vendor/haskell-tree-sitter @@ -1 +1 @@ -Subproject commit 6e120871e89e65038b4d214b83a0add7e76a4d73 +Subproject commit 6465254c6c8659c2eed44e29fec9d11b69adc639 From edf66f9b9852a42f259b740bb1ff19ba93eeca3b Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 11:22:18 -0700 Subject: [PATCH 52/72] Go has a new Identifier'' --- src/Language/Go/Assignment.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs index 1e51b7f7f..89c36431d 100644 --- a/src/Language/Go/Assignment.hs +++ b/src/Language/Go/Assignment.hs @@ -267,10 +267,10 @@ floatLiteral :: Assignment Term floatLiteral = makeTerm <$> symbol FloatLiteral <*> (Literal.Float <$> source) identifier :: Assignment Term -identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier') <*> (Syntax.Identifier . name <$> source) +identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') <*> (Syntax.Identifier . name <$> source) identifier' :: Assignment Name -identifier' = (symbol Identifier <|> symbol Identifier') *> (name <$> source) +identifier' = (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') *> (name <$> source) imaginaryLiteral :: Assignment Term imaginaryLiteral = makeTerm <$> symbol ImaginaryLiteral <*> (Literal.Complex <$> source) From 344873f0f77c2b1c3e1454d0aada297b511a70b5 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 17 Sep 2018 11:26:47 -0700 Subject: [PATCH 53/72] Go corpus back the other way? --- .../go/corpus/method-declarations.diffA-B.txt | 5 ++-- .../go/corpus/method-declarations.diffB-A.txt | 5 ++-- .../go/corpus/method-declarations.parseA.txt | 5 ++-- .../go/corpus/method-declarations.parseB.txt | 5 ++-- .../go/corpus/select-statements.diffA-B.txt | 5 ++-- .../go/corpus/select-statements.diffB-A.txt | 5 ++-- .../go/corpus/select-statements.parseA.txt | 5 ++-- .../go/corpus/select-statements.parseB.txt | 5 ++-- .../type-conversion-expressions.diffA-B.txt | 30 ++++++++++--------- .../type-conversion-expressions.diffB-A.txt | 30 ++++++++++--------- .../type-conversion-expressions.parseA.txt | 15 +++++----- .../type-conversion-expressions.parseB.txt | 15 +++++----- 12 files changed, 72 insertions(+), 58 deletions(-) diff --git a/test/fixtures/go/corpus/method-declarations.diffA-B.txt b/test/fixtures/go/corpus/method-declarations.diffA-B.txt index f7e35e0e0..66222ddb2 100644 --- a/test/fixtures/go/corpus/method-declarations.diffA-B.txt +++ b/test/fixtures/go/corpus/method-declarations.diffA-B.txt @@ -31,7 +31,7 @@ { (Identifier) ->(Identifier) } (Return - (TypeConversion + (Call (MemberAccess (Identifier)) (Plus @@ -66,7 +66,8 @@ {-(MemberAccess {-(Identifier)-})-}) ->(MemberAccess - {+(Identifier)+}) })))) + {+(Identifier)+}) }) + (Empty)))) (Method (Statements (Assignment diff --git a/test/fixtures/go/corpus/method-declarations.diffB-A.txt b/test/fixtures/go/corpus/method-declarations.diffB-A.txt index f1ca6156d..7e5b0207f 100644 --- a/test/fixtures/go/corpus/method-declarations.diffB-A.txt +++ b/test/fixtures/go/corpus/method-declarations.diffB-A.txt @@ -31,7 +31,7 @@ { (Identifier) ->(Identifier) } (Return - (TypeConversion + (Call (MemberAccess (Identifier)) (Plus @@ -66,7 +66,8 @@ {+(MemberAccess {+(Identifier)+})+} {+(MemberAccess - {+(Identifier)+})+}) })))) + {+(Identifier)+})+}) }) + (Empty)))) (Method (Statements (Assignment diff --git a/test/fixtures/go/corpus/method-declarations.parseA.txt b/test/fixtures/go/corpus/method-declarations.parseA.txt index a2493d1b8..9ef9be5de 100644 --- a/test/fixtures/go/corpus/method-declarations.parseA.txt +++ b/test/fixtures/go/corpus/method-declarations.parseA.txt @@ -27,7 +27,7 @@ (Identifier))) (Identifier) (Return - (TypeConversion + (Call (MemberAccess (Identifier)) (Plus @@ -40,7 +40,8 @@ (MemberAccess (Identifier)) (MemberAccess - (Identifier))))))) + (Identifier)))) + (Empty)))) (Method (Statements (Assignment diff --git a/test/fixtures/go/corpus/method-declarations.parseB.txt b/test/fixtures/go/corpus/method-declarations.parseB.txt index 3728c63e9..d7bcc40f9 100644 --- a/test/fixtures/go/corpus/method-declarations.parseB.txt +++ b/test/fixtures/go/corpus/method-declarations.parseB.txt @@ -27,7 +27,7 @@ (Identifier))) (Identifier) (Return - (TypeConversion + (Call (MemberAccess (Identifier)) (Plus @@ -52,7 +52,8 @@ (Integer)) (Empty))) (MemberAccess - (Identifier)))))) + (Identifier))) + (Empty)))) (Method (Statements (Assignment diff --git a/test/fixtures/go/corpus/select-statements.diffA-B.txt b/test/fixtures/go/corpus/select-statements.diffA-B.txt index e0b487368..a2c5e9747 100644 --- a/test/fixtures/go/corpus/select-statements.diffA-B.txt +++ b/test/fixtures/go/corpus/select-statements.diffA-B.txt @@ -29,11 +29,12 @@ (Receive (Empty) (ReceiveOperator - (TypeConversion + (Call (MemberAccess (Identifier)) { (Integer) - ->(Integer) }))) + ->(Integer) } + (Empty)))) (Statements (Call (Identifier) diff --git a/test/fixtures/go/corpus/select-statements.diffB-A.txt b/test/fixtures/go/corpus/select-statements.diffB-A.txt index e0ecbbe22..dbed25d39 100644 --- a/test/fixtures/go/corpus/select-statements.diffB-A.txt +++ b/test/fixtures/go/corpus/select-statements.diffB-A.txt @@ -29,11 +29,12 @@ (Receive (Empty) (ReceiveOperator - (TypeConversion + (Call (MemberAccess (Identifier)) { (Integer) - ->(Integer) }))) + ->(Integer) } + (Empty)))) (Statements (Call (Identifier) diff --git a/test/fixtures/go/corpus/select-statements.parseA.txt b/test/fixtures/go/corpus/select-statements.parseA.txt index d73079a32..df226d396 100644 --- a/test/fixtures/go/corpus/select-statements.parseA.txt +++ b/test/fixtures/go/corpus/select-statements.parseA.txt @@ -27,10 +27,11 @@ (Receive (Empty) (ReceiveOperator - (TypeConversion + (Call (MemberAccess (Identifier)) - (Integer)))) + (Integer) + (Empty)))) (Statements (Call (Identifier) diff --git a/test/fixtures/go/corpus/select-statements.parseB.txt b/test/fixtures/go/corpus/select-statements.parseB.txt index 339b089ac..c20a51893 100644 --- a/test/fixtures/go/corpus/select-statements.parseB.txt +++ b/test/fixtures/go/corpus/select-statements.parseB.txt @@ -27,10 +27,11 @@ (Receive (Empty) (ReceiveOperator - (TypeConversion + (Call (MemberAccess (Identifier)) - (Integer)))) + (Integer) + (Empty)))) (Statements (Call (Identifier) diff --git a/test/fixtures/go/corpus/type-conversion-expressions.diffA-B.txt b/test/fixtures/go/corpus/type-conversion-expressions.diffA-B.txt index c723523a0..eb3323ad2 100644 --- a/test/fixtures/go/corpus/type-conversion-expressions.diffA-B.txt +++ b/test/fixtures/go/corpus/type-conversion-expressions.diffA-B.txt @@ -70,21 +70,23 @@ {-(Identifier)-}) ->(MemberAccess {+(Identifier)+}) }) - {+(TypeConversion + {+(Call {+(MemberAccess {+(Identifier)+})+} - {+(Identifier)+})+} - {+(TypeConversion - {+(Parenthesized - {+(MemberAccess - {+(Identifier)+})+})+} - {+(Identifier)+})+} - {-(TypeConversion + {+(Identifier)+} + {+(Empty)+})+} + {+(Call + {+(MemberAccess + {+(Identifier)+})+} + {+(Identifier)+} + {+(Empty)+})+} + {-(Call {-(MemberAccess {-(Identifier)-})-} - {-(Identifier)-})-} - {-(TypeConversion - {-(Parenthesized - {-(MemberAccess - {-(Identifier)-})-})-} - {-(Identifier)-})-}))) + {-(Identifier)-} + {-(Empty)-})-} + {-(Call + {-(MemberAccess + {-(Identifier)-})-} + {-(Identifier)-} + {-(Empty)-})-}))) diff --git a/test/fixtures/go/corpus/type-conversion-expressions.diffB-A.txt b/test/fixtures/go/corpus/type-conversion-expressions.diffB-A.txt index c723523a0..eb3323ad2 100644 --- a/test/fixtures/go/corpus/type-conversion-expressions.diffB-A.txt +++ b/test/fixtures/go/corpus/type-conversion-expressions.diffB-A.txt @@ -70,21 +70,23 @@ {-(Identifier)-}) ->(MemberAccess {+(Identifier)+}) }) - {+(TypeConversion + {+(Call {+(MemberAccess {+(Identifier)+})+} - {+(Identifier)+})+} - {+(TypeConversion - {+(Parenthesized - {+(MemberAccess - {+(Identifier)+})+})+} - {+(Identifier)+})+} - {-(TypeConversion + {+(Identifier)+} + {+(Empty)+})+} + {+(Call + {+(MemberAccess + {+(Identifier)+})+} + {+(Identifier)+} + {+(Empty)+})+} + {-(Call {-(MemberAccess {-(Identifier)-})-} - {-(Identifier)-})-} - {-(TypeConversion - {-(Parenthesized - {-(MemberAccess - {-(Identifier)-})-})-} - {-(Identifier)-})-}))) + {-(Identifier)-} + {-(Empty)-})-} + {-(Call + {-(MemberAccess + {-(Identifier)-})-} + {-(Identifier)-} + {-(Empty)-})-}))) diff --git a/test/fixtures/go/corpus/type-conversion-expressions.parseA.txt b/test/fixtures/go/corpus/type-conversion-expressions.parseA.txt index 4d01c1fb1..783917ac3 100644 --- a/test/fixtures/go/corpus/type-conversion-expressions.parseA.txt +++ b/test/fixtures/go/corpus/type-conversion-expressions.parseA.txt @@ -54,12 +54,13 @@ (Identifier)))) (MemberAccess (Identifier))) - (TypeConversion + (Call (MemberAccess (Identifier)) - (Identifier)) - (TypeConversion - (Parenthesized - (MemberAccess - (Identifier))) - (Identifier))))) + (Identifier) + (Empty)) + (Call + (MemberAccess + (Identifier)) + (Identifier) + (Empty))))) diff --git a/test/fixtures/go/corpus/type-conversion-expressions.parseB.txt b/test/fixtures/go/corpus/type-conversion-expressions.parseB.txt index 4d01c1fb1..783917ac3 100644 --- a/test/fixtures/go/corpus/type-conversion-expressions.parseB.txt +++ b/test/fixtures/go/corpus/type-conversion-expressions.parseB.txt @@ -54,12 +54,13 @@ (Identifier)))) (MemberAccess (Identifier))) - (TypeConversion + (Call (MemberAccess (Identifier)) - (Identifier)) - (TypeConversion - (Parenthesized - (MemberAccess - (Identifier))) - (Identifier))))) + (Identifier) + (Empty)) + (Call + (MemberAccess + (Identifier)) + (Identifier) + (Empty))))) From e2bd55950d7eba2cf1ed1770c2c74d3a5f9d69e2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 17 Sep 2018 15:38:21 -0400 Subject: [PATCH 54/72] Widen the heap. --- src/Semantic/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 6e0e42614..ab3bbcd3f 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -111,8 +111,8 @@ runCallGraph lang includePackages modules package = do runGraphAnalysis = runTermEvaluator @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract . graphing @_ @_ @(Maybe Name) @Monovariant - . caching . runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) Abstract)) + . caching . runFresh 0 . resumingLoadError . resumingUnspecialized From 5043e62a7126ddb383c0f05afe729be54023fb22 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 09:59:37 -0400 Subject: [PATCH 55/72] Give the tracing analysis its own definition of Configuration. --- src/Analysis/Abstract/Tracing.hs | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 13073a138..988d2b054 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -4,9 +4,9 @@ module Analysis.Abstract.Tracing , tracing ) where -import Control.Abstract.Configuration -import Control.Abstract hiding (trace) +import Control.Abstract hiding (trace, Configuration) import Control.Monad.Effect.Writer +import Data.Abstract.Environment import Data.Semigroup.Reducer as Reducer import Prologue @@ -30,3 +30,19 @@ trace = tell tracing :: (Monoid (trace (Configuration term address value)), Effects effects) => TermEvaluator term address value (Writer (trace (Configuration term address value)) ': effects) a -> TermEvaluator term address value effects (trace (Configuration term address value), a) tracing = runWriter + + +-- | Get the current 'Configuration' with a passed-in term. +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects) + => term + -> TermEvaluator term address value effects (Configuration term address value) +getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap + +-- | A single point in a program’s execution. +data Configuration term address value = Configuration + { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. + , configurationRoots :: Live address -- ^ The set of rooted addresses. + , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. + , configurationHeap :: Heap address value -- ^ The heap of values. + } + deriving (Eq, Ord, Show) From c612b0d490ecb74cfb4fe09c4d19bf506c41e6c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:02:32 -0400 Subject: [PATCH 56/72] =?UTF-8?q?Tracing=20doesn=E2=80=99t=20require=20the?= =?UTF-8?q?=20live=20set.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Tracing.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 988d2b054..d195d56aa 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,6 @@ import Prologue -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. tracingTerms :: ( Corecursive term - , Member (Reader (Live address)) effects , Member (Env address) effects , Member (State (Heap address value)) effects , Member (Writer (trace (Configuration term address value))) effects @@ -33,15 +32,14 @@ tracing = runWriter -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects) +getConfiguration :: (Member (Env address) effects, Member (State (Heap address value)) effects) => term -> TermEvaluator term address value effects (Configuration term address value) -getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap +getConfiguration term = Configuration term <$> TermEvaluator getEvalContext <*> TermEvaluator getHeap -- | A single point in a program’s execution. data Configuration term address value = Configuration { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live address -- ^ The set of rooted addresses. , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. , configurationHeap :: Heap address value -- ^ The heap of values. } From d15790bce7deeef33f28081f4545420e076175d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:04:53 -0400 Subject: [PATCH 57/72] :fire: some trailing whitespace. --- src/Control/Abstract/Configuration.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index fe92bf8e6..77dd6121e 100644 --- a/src/Control/Abstract/Configuration.hs +++ b/src/Control/Abstract/Configuration.hs @@ -12,4 +12,3 @@ getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address => term -> TermEvaluator term address value effects (Configuration term address value) getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap - From 32d683fb20dfa8f51367f492bc67c32a48c65e58 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:05:03 -0400 Subject: [PATCH 58/72] =?UTF-8?q?Don=E2=80=99t=20re-export=20Configuration?= =?UTF-8?q?.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Caching.hs | 1 + src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Configuration.hs | 1 + src/Control/Abstract/Heap.hs | 2 -- 4 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index d09a5fe3d..a5cc19681 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -8,6 +8,7 @@ module Analysis.Abstract.Caching import Control.Abstract.Configuration import Control.Abstract import Data.Abstract.Cache +import Data.Abstract.Configuration import Data.Abstract.BaseError import Data.Abstract.Environment import Data.Abstract.Module diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index d195d56aa..b1b6cfdef 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -4,7 +4,7 @@ module Analysis.Abstract.Tracing , tracing ) where -import Control.Abstract hiding (trace, Configuration) +import Control.Abstract hiding (trace) import Control.Monad.Effect.Writer import Data.Abstract.Environment import Data.Semigroup.Reducer as Reducer diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs index 77dd6121e..297ce1a16 100644 --- a/src/Control/Abstract/Configuration.hs +++ b/src/Control/Abstract/Configuration.hs @@ -6,6 +6,7 @@ import Control.Abstract.Environment import Control.Abstract.Heap import Control.Abstract.Roots import Control.Abstract.TermEvaluator +import Data.Abstract.Configuration -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index c0c46e2d9..1e7f742a1 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -1,7 +1,6 @@ {-# LANGUAGE GADTs, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-} module Control.Abstract.Heap ( Heap -, Configuration(..) , Live , getHeap , putHeap @@ -22,7 +21,6 @@ module Control.Abstract.Heap import Control.Abstract.Evaluator import Control.Abstract.Roots -import Data.Abstract.Configuration import Data.Abstract.BaseError import Data.Abstract.Heap import Data.Abstract.Live From 3a760445e3cf3b17250c1cc8d2690014dc2f0d4c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:08:48 -0400 Subject: [PATCH 59/72] Give Caching its own definition of getConfiguration. --- src/Analysis/Abstract/Caching.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index a5cc19681..fc068ae3e 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -5,7 +5,6 @@ module Analysis.Abstract.Caching , caching ) where -import Control.Abstract.Configuration import Control.Abstract import Data.Abstract.Cache import Data.Abstract.Configuration @@ -130,6 +129,12 @@ converge seed f = loop seed scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> TermEvaluator term address value effects (ValueRef address) scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value) +-- | Get the current 'Configuration' with a passed-in term. +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects) + => term + -> TermEvaluator term address value effects (Configuration term address value) +getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap + caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> TermEvaluator term address value effects (Cache term address value, [a]) caching From 51be2081ae3b10b80399e6300d79631664a60c77 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:10:03 -0400 Subject: [PATCH 60/72] :fire: Control.Abstract.Configuration. --- semantic.cabal | 1 - src/Control/Abstract/Configuration.hs | 15 --------------- 2 files changed, 16 deletions(-) delete mode 100644 src/Control/Abstract/Configuration.hs diff --git a/semantic.cabal b/semantic.cabal index ec2cd8b1e..6567ed4c2 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -35,7 +35,6 @@ library , Assigning.Assignment.Table -- Control structures & interfaces for abstract interpretation , Control.Abstract - , Control.Abstract.Configuration , Control.Abstract.Context , Control.Abstract.Environment , Control.Abstract.Evaluator diff --git a/src/Control/Abstract/Configuration.hs b/src/Control/Abstract/Configuration.hs deleted file mode 100644 index 297ce1a16..000000000 --- a/src/Control/Abstract/Configuration.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Control.Abstract.Configuration -( getConfiguration -) where - -import Control.Abstract.Environment -import Control.Abstract.Heap -import Control.Abstract.Roots -import Control.Abstract.TermEvaluator -import Data.Abstract.Configuration - --- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects) - => term - -> TermEvaluator term address value effects (Configuration term address value) -getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap From 86654a2dab6aab34146e7030b7e7a99f225759bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:12:02 -0400 Subject: [PATCH 61/72] Move Configuration into Data.Abstract.Cache. --- semantic.cabal | 1 - src/Analysis/Abstract/Caching.hs | 1 - src/Data/Abstract/Cache.hs | 13 ++++++++++++- src/Data/Abstract/Configuration.hs | 14 -------------- 4 files changed, 12 insertions(+), 17 deletions(-) delete mode 100644 src/Data/Abstract/Configuration.hs diff --git a/semantic.cabal b/semantic.cabal index 6567ed4c2..0960b9398 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -54,7 +54,6 @@ library , Data.Abstract.Address.Precise , Data.Abstract.BaseError , Data.Abstract.Cache - , Data.Abstract.Configuration , Data.Abstract.Declarations , Data.Abstract.Environment , Data.Abstract.Evaluatable diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index fc068ae3e..0fee12dff 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -7,7 +7,6 @@ module Analysis.Abstract.Caching import Control.Abstract import Data.Abstract.Cache -import Data.Abstract.Configuration import Data.Abstract.BaseError import Data.Abstract.Environment import Data.Abstract.Module diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 1db43d5a6..615acc805 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} module Data.Abstract.Cache ( Cache + , Configuration (..) , Cached (..) , Cacheable , cacheLookup @@ -9,8 +10,9 @@ module Data.Abstract.Cache , cacheKeys ) where -import Data.Abstract.Configuration +import Data.Abstract.Environment import Data.Abstract.Heap +import Data.Abstract.Live import Data.Abstract.Ref import Data.Map.Monoidal as Monoidal import Prologue @@ -19,6 +21,15 @@ import Prologue newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) } deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup) +-- | A single point in a program’s execution. +data Configuration term address value = Configuration + { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. + , configurationRoots :: Live address -- ^ The set of rooted addresses. + , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. + , configurationHeap :: Heap address value -- ^ The heap of values. + } + deriving (Eq, Ord, Show) + data Cached address value = Cached { cachedValue :: ValueRef address , cachedHeap :: Heap address value diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs deleted file mode 100644 index 6f6a23e48..000000000 --- a/src/Data/Abstract/Configuration.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Data.Abstract.Configuration ( Configuration (..) ) where - -import Data.Abstract.Environment -import Data.Abstract.Heap -import Data.Abstract.Live - --- | A single point in a program’s execution. -data Configuration term address value = Configuration - { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live address -- ^ The set of rooted addresses. - , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. - , configurationHeap :: Heap address value -- ^ The heap of values. - } - deriving (Eq, Ord, Show) From 560c93784c2ce08ac4256da72bb6d22b7322649a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:21:25 -0400 Subject: [PATCH 62/72] Move the cache into the Caching module. --- semantic.cabal | 1 - src/Analysis/Abstract/Caching.hs | 42 +++++++++++++++++++++-- src/Data/Abstract/Cache.hs | 59 -------------------------------- 3 files changed, 40 insertions(+), 62 deletions(-) delete mode 100644 src/Data/Abstract/Cache.hs diff --git a/semantic.cabal b/semantic.cabal index 0960b9398..c0c705c4a 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -53,7 +53,6 @@ library , Data.Abstract.Address.Monovariant , Data.Abstract.Address.Precise , Data.Abstract.BaseError - , Data.Abstract.Cache , Data.Abstract.Declarations , Data.Abstract.Environment , Data.Abstract.Evaluatable diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 0fee12dff..277c8c6bd 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, TypeOperators #-} +{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, TypeOperators #-} module Analysis.Abstract.Caching ( cachingTerms , convergingModules @@ -6,11 +6,11 @@ module Analysis.Abstract.Caching ) where import Control.Abstract -import Data.Abstract.Cache import Data.Abstract.BaseError import Data.Abstract.Environment import Data.Abstract.Module import Data.Abstract.Ref +import Data.Map.Monoidal as Monoidal import Prologue -- | Look up the set of values for a given configuration in the in-cache. @@ -140,3 +140,41 @@ caching = runState lowerBound . runReader lowerBound . runNonDet + + +-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's. +newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) } + deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup) + +-- | A single point in a program’s execution. +data Configuration term address value = Configuration + { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. + , configurationRoots :: Live address -- ^ The set of rooted addresses. + , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. + , configurationHeap :: Heap address value -- ^ The heap of values. + } + deriving (Eq, Ord, Show) + +data Cached address value = Cached + { cachedValue :: ValueRef address + , cachedHeap :: Heap address value + } + deriving (Eq, Ord, Show) + + +type Cacheable term address value = (Ord address, Ord term, Ord value) + +-- | Look up the resulting value & 'Heap' for a given 'Configuration'. +cacheLookup :: Cacheable term address value => Configuration term address value -> Cache term address value -> Maybe (Set (Cached address value)) +cacheLookup key = Monoidal.lookup key . unCache + +-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry. +cacheSet :: Cacheable term address value => Configuration term address value -> Set (Cached address value) -> Cache term address value -> Cache term address value +cacheSet key value = Cache . Monoidal.insert key value . unCache + +-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry. +cacheInsert :: Cacheable term address value => Configuration term address value -> Cached address value -> Cache term address value -> Cache term address value +cacheInsert = curry cons + +instance (Show term, Show address, Show value) => Show (Cache term address value) where + showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs deleted file mode 100644 index 615acc805..000000000 --- a/src/Data/Abstract/Cache.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} -module Data.Abstract.Cache - ( Cache - , Configuration (..) - , Cached (..) - , Cacheable - , cacheLookup - , cacheSet - , cacheInsert - , cacheKeys - ) where - -import Data.Abstract.Environment -import Data.Abstract.Heap -import Data.Abstract.Live -import Data.Abstract.Ref -import Data.Map.Monoidal as Monoidal -import Prologue - --- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's. -newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) } - deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup) - --- | A single point in a program’s execution. -data Configuration term address value = Configuration - { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live address -- ^ The set of rooted addresses. - , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. - , configurationHeap :: Heap address value -- ^ The heap of values. - } - deriving (Eq, Ord, Show) - -data Cached address value = Cached - { cachedValue :: ValueRef address - , cachedHeap :: Heap address value - } - deriving (Eq, Ord, Show) - - -type Cacheable term address value = (Ord address, Ord term, Ord value) - --- | Look up the resulting value & 'Heap' for a given 'Configuration'. -cacheLookup :: Cacheable term address value => Configuration term address value -> Cache term address value -> Maybe (Set (Cached address value)) -cacheLookup key = Monoidal.lookup key . unCache - --- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry. -cacheSet :: Cacheable term address value => Configuration term address value -> Set (Cached address value) -> Cache term address value -> Cache term address value -cacheSet key value = Cache . Monoidal.insert key value . unCache - --- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry. -cacheInsert :: Cacheable term address value => Configuration term address value -> Cached address value -> Cache term address value -> Cache term address value -cacheInsert = curry cons - --- | Return all 'Configuration's in the provided cache. -cacheKeys :: Cache term address value -> [Configuration term address value] -cacheKeys = Monoidal.keys . unCache - -instance (Show term, Show address, Show value) => Show (Cache term address value) where - showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache From 58c22658d356fc6c8f9a635d0a98adcb3b6626ce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:26:50 -0400 Subject: [PATCH 63/72] Rename the Caching module to note its flow-sensitivity. --- semantic.cabal | 2 +- src/Analysis/Abstract/{Caching.hs => Caching/FlowSensitive.hs} | 2 +- src/Semantic/Graph.hs | 2 +- src/Semantic/Util.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) rename src/Analysis/Abstract/{Caching.hs => Caching/FlowSensitive.hs} (99%) diff --git a/semantic.cabal b/semantic.cabal index c0c705c4a..a218006ac 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -19,7 +19,7 @@ library hs-source-dirs: src exposed-modules: -- Analyses & term annotations - Analysis.Abstract.Caching + Analysis.Abstract.Caching.FlowSensitive , Analysis.Abstract.Collecting , Analysis.Abstract.Dead , Analysis.Abstract.Graph diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching/FlowSensitive.hs similarity index 99% rename from src/Analysis/Abstract/Caching.hs rename to src/Analysis/Abstract/Caching/FlowSensitive.hs index 277c8c6bd..51a09dd0d 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching/FlowSensitive.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, TypeOperators #-} -module Analysis.Abstract.Caching +module Analysis.Abstract.Caching.FlowSensitive ( cachingTerms , convergingModules , caching diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index ab3bbcd3f..cad685c15 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -26,7 +26,7 @@ module Semantic.Graph import Prelude hiding (readFile) -import Analysis.Abstract.Caching +import Analysis.Abstract.Caching.FlowSensitive import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph import Control.Abstract diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 39e186616..dcde89dcb 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -4,7 +4,7 @@ module Semantic.Util where import Prelude hiding (id, (.), readFile) -import Analysis.Abstract.Caching +import Analysis.Abstract.Caching.FlowSensitive import Analysis.Abstract.Collecting import Control.Abstract import Control.Category From 87c609fa1cc5579a1e70204a7e2c9e9d5ee8d646 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:27:47 -0400 Subject: [PATCH 64/72] Duplicate the flow-sensitive caching module. --- semantic.cabal | 3 +- .../Abstract/Caching/FlowInsensitive.hs | 180 ++++++++++++++++++ 2 files changed, 182 insertions(+), 1 deletion(-) create mode 100644 src/Analysis/Abstract/Caching/FlowInsensitive.hs diff --git a/semantic.cabal b/semantic.cabal index a218006ac..d3a0cbcb6 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -19,7 +19,8 @@ library hs-source-dirs: src exposed-modules: -- Analyses & term annotations - Analysis.Abstract.Caching.FlowSensitive + Analysis.Abstract.Caching.FlowInsensitive + , Analysis.Abstract.Caching.FlowSensitive , Analysis.Abstract.Collecting , Analysis.Abstract.Dead , Analysis.Abstract.Graph diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs new file mode 100644 index 000000000..6a5c172c4 --- /dev/null +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, TypeOperators #-} +module Analysis.Abstract.Caching.FlowInsensitive +( cachingTerms +, convergingModules +, caching +) where + +import Control.Abstract +import Data.Abstract.BaseError +import Data.Abstract.Environment +import Data.Abstract.Module +import Data.Abstract.Ref +import Data.Map.Monoidal as Monoidal +import Prologue + +-- | Look up the set of values for a given configuration in the in-cache. +consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) effects) + => Configuration term address value + -> TermEvaluator term address value effects (Set (Cached address value)) +consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask + +-- | Run an action with the given in-cache. +withOracle :: Member (Reader (Cache term address value)) effects + => Cache term address value + -> TermEvaluator term address value effects a + -> TermEvaluator term address value effects a +withOracle cache = local (const cache) + + +-- | Look up the set of values for a given configuration in the out-cache. +lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) effects) + => Configuration term address value + -> TermEvaluator term address value effects (Maybe (Set (Cached address value))) +lookupCache configuration = cacheLookup configuration <$> get + +-- | Run an action, caching its result and 'Heap' under the given configuration. +cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) effects, Member (State (Heap address value)) effects) + => Configuration term address value + -> Set (Cached address value) + -> TermEvaluator term address value effects (ValueRef address) + -> TermEvaluator term address value effects (ValueRef address) +cachingConfiguration configuration values action = do + modify' (cacheSet configuration values) + result <- Cached <$> action <*> TermEvaluator getHeap + cachedValue result <$ modify' (cacheInsert configuration result) + +putCache :: Member (State (Cache term address value)) effects + => Cache term address value + -> TermEvaluator term address value effects () +putCache = put + +-- | Run an action starting from an empty out-cache, and return the out-cache afterwards. +isolateCache :: Member (State (Cache term address value)) effects + => TermEvaluator term address value effects a + -> TermEvaluator term address value effects (Cache term address value) +isolateCache action = putCache lowerBound *> action *> get + + +-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. +cachingTerms :: ( Cacheable term address value + , Corecursive term + , Member NonDet effects + , Member (Reader (Cache term address value)) effects + , Member (Reader (Live address)) effects + , Member (State (Cache term address value)) effects + , Member (Env address) effects + , Member (State (Heap address value)) effects + ) + => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) + -> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) +cachingTerms recur term = do + c <- getConfiguration (embedSubterm term) + cached <- lookupCache c + case cached of + Just pairs -> scatter pairs + Nothing -> do + pairs <- consultOracle c + cachingConfiguration c pairs (recur term) + +convergingModules :: ( AbstractValue address value effects + , Cacheable term address value + , Member Fresh effects + , Member NonDet effects + , Member (Reader (Cache term address value)) effects + , Member (Reader (Live address)) effects + , Member (Reader ModuleInfo) effects + , Member (Reader Span) effects + , Member (Resumable (BaseError (EnvironmentError address))) effects + , Member (State (Cache term address value)) effects + , Member (Env address) effects + , Member (State (Heap address value)) effects + , Effects effects + ) + => SubtermAlgebra Module term (TermEvaluator term address value effects address) + -> SubtermAlgebra Module term (TermEvaluator term address value effects address) +convergingModules recur m = do + c <- getConfiguration (subterm (moduleBody m)) + -- Convergence here is predicated upon an Eq instance, not α-equivalence + cache <- converge lowerBound (\ prevCache -> isolateCache $ do + TermEvaluator (putHeap (configurationHeap c)) + TermEvaluator (putEvalContext (configurationContext c)) + -- We need to reset fresh generation so that this invocation converges. + resetFresh 0 $ + -- This is subtle: though the calling context supports nondeterminism, we want + -- to corral all the nondeterminism that happens in this @eval@ invocation, so + -- that it doesn't "leak" to the calling context and diverge (otherwise this + -- would never complete). We don’t need to use the values, so we 'gather' the + -- nondeterministic values into @()@. + withOracle prevCache (gatherM (const ()) (recur m))) + TermEvaluator (address =<< runTermEvaluator (maybe empty scatter (cacheLookup c cache))) + +-- | Iterate a monadic action starting from some initial seed until the results converge. +-- +-- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem +converge :: (Eq a, Monad m) + => a -- ^ An initial seed value to iterate from. + -> (a -> m a) -- ^ A monadic action to perform at each iteration, starting from the result of the previous iteration or from the seed value for the first iteration. + -> m a -- ^ A computation producing the least fixed point (the first value at which the actions converge). +converge seed f = loop seed + where loop x = do + x' <- f x + if x' == x then + pure x + else + loop x' + +-- | Nondeterministically write each of a collection of stores & return their associated results. +scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> TermEvaluator term address value effects (ValueRef address) +scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value) + +-- | Get the current 'Configuration' with a passed-in term. +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects) + => term + -> TermEvaluator term address value effects (Configuration term address value) +getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap + + +caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> TermEvaluator term address value effects (Cache term address value, [a]) +caching + = runState lowerBound + . runReader lowerBound + . runNonDet + + +-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's. +newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) } + deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup) + +-- | A single point in a program’s execution. +data Configuration term address value = Configuration + { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. + , configurationRoots :: Live address -- ^ The set of rooted addresses. + , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. + , configurationHeap :: Heap address value -- ^ The heap of values. + } + deriving (Eq, Ord, Show) + +data Cached address value = Cached + { cachedValue :: ValueRef address + , cachedHeap :: Heap address value + } + deriving (Eq, Ord, Show) + + +type Cacheable term address value = (Ord address, Ord term, Ord value) + +-- | Look up the resulting value & 'Heap' for a given 'Configuration'. +cacheLookup :: Cacheable term address value => Configuration term address value -> Cache term address value -> Maybe (Set (Cached address value)) +cacheLookup key = Monoidal.lookup key . unCache + +-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry. +cacheSet :: Cacheable term address value => Configuration term address value -> Set (Cached address value) -> Cache term address value -> Cache term address value +cacheSet key value = Cache . Monoidal.insert key value . unCache + +-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry. +cacheInsert :: Cacheable term address value => Configuration term address value -> Cached address value -> Cache term address value -> Cache term address value +cacheInsert = curry cons + +instance (Show term, Show address, Show value) => Show (Cache term address value) where + showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache From dec0f3f84506885f684c3f97255b039283a20b18 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:33:34 -0400 Subject: [PATCH 65/72] Remove Heaps from the flow-insensitive cache. --- .../Abstract/Caching/FlowInsensitive.hs | 104 ++++++++---------- 1 file changed, 47 insertions(+), 57 deletions(-) diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs index 6a5c172c4..f2602c215 100644 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, TypeOperators #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators #-} module Analysis.Abstract.Caching.FlowInsensitive ( cachingTerms , convergingModules @@ -14,57 +14,57 @@ import Data.Map.Monoidal as Monoidal import Prologue -- | Look up the set of values for a given configuration in the in-cache. -consultOracle :: (Cacheable term address value, Member (Reader (Cache term address value)) effects) - => Configuration term address value - -> TermEvaluator term address value effects (Set (Cached address value)) +consultOracle :: (Member (Reader (Cache term address)) effects, Ord address, Ord term) + => Configuration term address + -> TermEvaluator term address value effects (Set (ValueRef address)) consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask -- | Run an action with the given in-cache. -withOracle :: Member (Reader (Cache term address value)) effects - => Cache term address value +withOracle :: Member (Reader (Cache term address)) effects + => Cache term address -> TermEvaluator term address value effects a -> TermEvaluator term address value effects a withOracle cache = local (const cache) -- | Look up the set of values for a given configuration in the out-cache. -lookupCache :: (Cacheable term address value, Member (State (Cache term address value)) effects) - => Configuration term address value - -> TermEvaluator term address value effects (Maybe (Set (Cached address value))) +lookupCache :: (Member (State (Cache term address)) effects, Ord address, Ord term) + => Configuration term address + -> TermEvaluator term address value effects (Maybe (Set (ValueRef address))) lookupCache configuration = cacheLookup configuration <$> get -- | Run an action, caching its result and 'Heap' under the given configuration. -cachingConfiguration :: (Cacheable term address value, Member (State (Cache term address value)) effects, Member (State (Heap address value)) effects) - => Configuration term address value - -> Set (Cached address value) +cachingConfiguration :: (Member (State (Cache term address)) effects, Ord address, Ord term) + => Configuration term address + -> Set (ValueRef address) -> TermEvaluator term address value effects (ValueRef address) -> TermEvaluator term address value effects (ValueRef address) cachingConfiguration configuration values action = do modify' (cacheSet configuration values) - result <- Cached <$> action <*> TermEvaluator getHeap - cachedValue result <$ modify' (cacheInsert configuration result) + result <- action + result <$ modify' (cacheInsert configuration result) -putCache :: Member (State (Cache term address value)) effects - => Cache term address value +putCache :: Member (State (Cache term address)) effects + => Cache term address -> TermEvaluator term address value effects () putCache = put -- | Run an action starting from an empty out-cache, and return the out-cache afterwards. -isolateCache :: Member (State (Cache term address value)) effects +isolateCache :: Member (State (Cache term address)) effects => TermEvaluator term address value effects a - -> TermEvaluator term address value effects (Cache term address value) + -> TermEvaluator term address value effects (Cache term address) isolateCache action = putCache lowerBound *> action *> get -- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. -cachingTerms :: ( Cacheable term address value - , Corecursive term - , Member NonDet effects - , Member (Reader (Cache term address value)) effects - , Member (Reader (Live address)) effects - , Member (State (Cache term address value)) effects +cachingTerms :: ( Corecursive term , Member (Env address) effects - , Member (State (Heap address value)) effects + , Member NonDet effects + , Member (Reader (Cache term address)) effects + , Member (Reader (Live address)) effects + , Member (State (Cache term address)) effects + , Ord address + , Ord term ) => SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef address)) @@ -72,24 +72,24 @@ cachingTerms recur term = do c <- getConfiguration (embedSubterm term) cached <- lookupCache c case cached of - Just pairs -> scatter pairs + Just values -> scatter values Nothing -> do - pairs <- consultOracle c - cachingConfiguration c pairs (recur term) + values <- consultOracle c + cachingConfiguration c values (recur term) convergingModules :: ( AbstractValue address value effects - , Cacheable term address value + , Effects effects + , Member (Env address) effects , Member Fresh effects , Member NonDet effects - , Member (Reader (Cache term address value)) effects + , Member (Reader (Cache term address)) effects , Member (Reader (Live address)) effects , Member (Reader ModuleInfo) effects , Member (Reader Span) effects , Member (Resumable (BaseError (EnvironmentError address))) effects - , Member (State (Cache term address value)) effects - , Member (Env address) effects - , Member (State (Heap address value)) effects - , Effects effects + , Member (State (Cache term address)) effects + , Ord address + , Ord term ) => SubtermAlgebra Module term (TermEvaluator term address value effects address) -> SubtermAlgebra Module term (TermEvaluator term address value effects address) @@ -97,7 +97,6 @@ convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge lowerBound (\ prevCache -> isolateCache $ do - TermEvaluator (putHeap (configurationHeap c)) TermEvaluator (putEvalContext (configurationContext c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ @@ -125,17 +124,17 @@ converge seed f = loop seed loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address value)) effects) => t (Cached address value) -> TermEvaluator term address value effects (ValueRef address) -scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value) +scatter :: (Foldable t, Member NonDet effects) => t (ValueRef address) -> TermEvaluator term address value effects (ValueRef address) +scatter = foldMapA pure -- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects, Member (State (Heap address value)) effects) +getConfiguration :: (Member (Reader (Live address)) effects, Member (Env address) effects) => term - -> TermEvaluator term address value effects (Configuration term address value) -getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext <*> TermEvaluator getHeap + -> TermEvaluator term address value effects (Configuration term address) +getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEvalContext -caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address value) ': State (Cache term address value) ': effects) a -> TermEvaluator term address value effects (Cache term address value, [a]) +caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address) ': State (Cache term address) ': effects) a -> TermEvaluator term address value effects (Cache term address, [a]) caching = runState lowerBound . runReader lowerBound @@ -143,38 +142,29 @@ caching -- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's. -newtype Cache term address value = Cache { unCache :: Monoidal.Map (Configuration term address value) (Set (Cached address value)) } - deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address value, Cached address value), Semigroup) +newtype Cache term address = Cache { unCache :: Monoidal.Map (Configuration term address) (Set (ValueRef address)) } + deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address, ValueRef address), Semigroup) -- | A single point in a program’s execution. -data Configuration term address value = Configuration +data Configuration term address = Configuration { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. , configurationRoots :: Live address -- ^ The set of rooted addresses. , configurationContext :: EvalContext address -- ^ The evaluation context in 'configurationTerm'. - , configurationHeap :: Heap address value -- ^ The heap of values. } deriving (Eq, Ord, Show) -data Cached address value = Cached - { cachedValue :: ValueRef address - , cachedHeap :: Heap address value - } - deriving (Eq, Ord, Show) - - -type Cacheable term address value = (Ord address, Ord term, Ord value) -- | Look up the resulting value & 'Heap' for a given 'Configuration'. -cacheLookup :: Cacheable term address value => Configuration term address value -> Cache term address value -> Maybe (Set (Cached address value)) +cacheLookup :: (Ord address, Ord term) => Configuration term address -> Cache term address -> Maybe (Set (ValueRef address)) cacheLookup key = Monoidal.lookup key . unCache -- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry. -cacheSet :: Cacheable term address value => Configuration term address value -> Set (Cached address value) -> Cache term address value -> Cache term address value +cacheSet :: (Ord address, Ord term) => Configuration term address -> Set (ValueRef address) -> Cache term address -> Cache term address cacheSet key value = Cache . Monoidal.insert key value . unCache -- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry. -cacheInsert :: Cacheable term address value => Configuration term address value -> Cached address value -> Cache term address value -> Cache term address value +cacheInsert :: (Ord address, Ord term) => Configuration term address -> ValueRef address -> Cache term address -> Cache term address cacheInsert = curry cons -instance (Show term, Show address, Show value) => Show (Cache term address value) where +instance (Show term, Show address) => Show (Cache term address) where showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache From 49251bbf27aee9535832a975363ee9c0489b5a07 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:45:37 -0400 Subject: [PATCH 66/72] Compute the least fixed-point of the cache and heap. --- src/Analysis/Abstract/Caching/FlowInsensitive.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs index f2602c215..64f96bad6 100644 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -50,10 +50,10 @@ putCache :: Member (State (Cache term address)) effects putCache = put -- | Run an action starting from an empty out-cache, and return the out-cache afterwards. -isolateCache :: Member (State (Cache term address)) effects +isolateCache :: (Member (State (Cache term address)) effects, Member (State (Heap address value)) effects) => TermEvaluator term address value effects a - -> TermEvaluator term address value effects (Cache term address) -isolateCache action = putCache lowerBound *> action *> get + -> TermEvaluator term address value effects (Cache term address, Heap address value) +isolateCache action = putCache lowerBound *> action *> ((,) <$> get <*> get) -- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. @@ -79,6 +79,7 @@ cachingTerms recur term = do convergingModules :: ( AbstractValue address value effects , Effects effects + , Eq value , Member (Env address) effects , Member Fresh effects , Member NonDet effects @@ -88,6 +89,7 @@ convergingModules :: ( AbstractValue address value effects , Member (Reader Span) effects , Member (Resumable (BaseError (EnvironmentError address))) effects , Member (State (Cache term address)) effects + , Member (State (Heap address value)) effects , Ord address , Ord term ) @@ -95,8 +97,9 @@ convergingModules :: ( AbstractValue address value effects -> SubtermAlgebra Module term (TermEvaluator term address value effects address) convergingModules recur m = do c <- getConfiguration (subterm (moduleBody m)) + heap <- TermEvaluator getHeap -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge lowerBound (\ prevCache -> isolateCache $ do + (cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do TermEvaluator (putEvalContext (configurationContext c)) -- We need to reset fresh generation so that this invocation converges. resetFresh 0 $ From c50cc165f6dc147a87880a56781d13cc6426a6ef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 18 Sep 2018 10:46:17 -0400 Subject: [PATCH 67/72] Use the flow-insensitive caching algorithm. --- src/Semantic/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index cad685c15..a512487db 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -26,7 +26,7 @@ module Semantic.Graph import Prelude hiding (readFile) -import Analysis.Abstract.Caching.FlowSensitive +import Analysis.Abstract.Caching.FlowInsensitive import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph import Control.Abstract From 12e1fe3a883694210c02c066ffe4e899638b5028 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 18 Sep 2018 09:07:21 -0700 Subject: [PATCH 68/72] ++tree-sitter --- vendor/haskell-tree-sitter | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/haskell-tree-sitter b/vendor/haskell-tree-sitter index 6465254c6..09ff8a81c 160000 --- a/vendor/haskell-tree-sitter +++ b/vendor/haskell-tree-sitter @@ -1 +1 @@ -Subproject commit 6465254c6c8659c2eed44e29fec9d11b69adc639 +Subproject commit 09ff8a81cd92a696939eb82e0c33111bde3f0376 From 8c917e3523c762b3c4175c02aad3ed78ad5b3a93 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 18 Sep 2018 12:25:43 -0400 Subject: [PATCH 69/72] Add lowerBound instance --- src/Control/Abstract/ScopeGraph.hs | 2 +- src/Data/Abstract/ScopeGraph.hs | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 86c889d97..76ac5251c 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -73,7 +73,7 @@ instance Effect (ScopeEnv address) where runScopeEnv :: (Ord address, Effects effects, Member Fresh effects, Member (Allocator address) effects) => Evaluator address value (ScopeEnv address ': effects) a -> Evaluator address value effects (ScopeGraph address, a) -runScopeEnv evaluator = runState ScopeGraph.emptyGraph (reinterpret handleScopeEnv evaluator) +runScopeEnv evaluator = runState lowerBound (reinterpret handleScopeEnv evaluator) handleScopeEnv :: forall address value effects a. (Ord address, Member Fresh effects, Member (Allocator address) effects, Effects effects) => ScopeEnv address (Eff (ScopeEnv address ': effects)) a diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 7c06df877..5efc7571b 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -18,7 +18,6 @@ module Data.Abstract.ScopeGraph , scopeOfRef , pathOfRef , declare - , emptyGraph , reference , newScope , associatedScope @@ -46,8 +45,8 @@ data Scope scopeAddress = Scope { data ScopeGraph scope = ScopeGraph { graph :: Map scope (Scope scope), currentScope :: Maybe scope } -emptyGraph :: Ord scope => ScopeGraph scope -emptyGraph = ScopeGraph mempty Nothing +instance Ord scope => Lower (ScopeGraph scope) where + lowerBound = ScopeGraph mempty Nothing deriving instance Eq address => Eq (ScopeGraph address) deriving instance Show address => Show (ScopeGraph address) From 1c95f42ff8abd2a22f506b68bad623bd121b70a1 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 18 Sep 2018 12:25:58 -0400 Subject: [PATCH 70/72] Rename and document EdgeLabel --- src/Data/Abstract/ScopeGraph.hs | 6 ++++-- src/Data/Syntax/Declaration.hs | 4 ++-- src/Data/Syntax/Statement.hs | 4 ++-- src/Language/TypeScript/Syntax/TypeScript.hs | 2 +- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 5efc7571b..234a89d8a 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -113,7 +113,7 @@ reference ref declaration g@ScopeGraph{..} = fromMaybe g $ do scopes <- Map.lookup edge linkMap -- Return the first path to the declaration through the scopes. getFirst (foldMap (First . ap (go currentAddress currentScope) ((path .) . EPath edge)) scopes) - in traverseEdges I <|> traverseEdges P + in traverseEdges Import <|> traverseEdges Lexical -- | Insert associate the given address to a declaration in the scope graph. insertDeclarationScope :: Ord address => Declaration -> address -> ScopeGraph address -> ScopeGraph address @@ -172,7 +172,9 @@ newtype Reference = Reference Name newtype Declaration = Declaration Name deriving (Eq, Ord, Show) -data EdgeLabel = P | I +-- | The type of edge from a scope to its parent scopes. +-- Either a lexical edge or an import edge in the case of non-lexical edges. +data EdgeLabel = Lexical | Import deriving (Eq, Ord, Show) data Frame scopeAddress frameAddress value = Frame { diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 7897d89c7..f52e36d87 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -215,8 +215,8 @@ instance Evaluatable Class where scope <- associatedScope (Declaration name) (scope,) <$> subtermAddress superclass - let imports = (I,) <$> (fmap pure . catMaybes $ fst <$> supers) - current = maybe mempty (fmap (P, ) . pure . pure) currentScope' + let imports = (Import,) <$> (fmap pure . catMaybes $ fst <$> supers) + current = maybe mempty (fmap (Lexical, ) . pure . pure) currentScope' edges = Map.fromList (imports <> current) childScope <- newScope edges declare (Declaration name) span (Just childScope) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index bf7135db5..65a5fb444 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -31,7 +31,7 @@ instance ToJSON1 Statements instance Evaluatable Statements where eval (Statements xs) = do currentScope' <- currentScope - let edges = maybe mempty (Map.singleton P . pure) currentScope' + let edges = maybe mempty (Map.singleton Lexical . pure) currentScope' scope <- newScope edges withScope scope $ maybe (rvalBox unit) (runApp . foldMap1 (App . subtermRef)) (nonEmpty xs) @@ -148,7 +148,7 @@ instance Evaluatable Assignment where assocScope <- associatedScope (Declaration rhsName) case assocScope of Just assocScope' -> do - objectScope <- newScope (Map.singleton I [ assocScope' ]) + objectScope <- newScope (Map.singleton Import [ assocScope' ]) putDeclarationScope (Declaration name) objectScope Nothing -> pure () Nothing -> diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index c39134014..e96482686 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -10,7 +10,7 @@ import Proto3.Suite import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import Control.Abstract.ScopeGraph +import Control.Abstract.ScopeGraph hiding (Import) import Data.JSON.Fields import Diffing.Algorithm import Language.TypeScript.Resolution From e6d26ed3224e8ffb53f8a5a969811ee85cb07290 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 18 Sep 2018 12:34:13 -0400 Subject: [PATCH 71/72] lowerBound --- src/Semantic/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index e9eca0703..f691bd4ee 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -356,7 +356,7 @@ resumingLoadError :: ( Applicative (m address value effects) => m address value (Resumable (BaseError (LoadError address)) ': effects) a -> m address value effects a resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of - ModuleNotFoundError _ -> pure (ScopeGraph.emptyGraph, (lowerBound, hole))) + ModuleNotFoundError _ -> pure (lowerBound, (lowerBound, hole))) resumingEvalError :: ( Applicative (m effects) , Effectful m From bb08efad3169ec79364edafb34c1a03dc0401211 Mon Sep 17 00:00:00 2001 From: joshvera Date: Tue, 18 Sep 2018 12:36:25 -0400 Subject: [PATCH 72/72] remove import --- src/Semantic/Graph.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index f691bd4ee..6cbb643e3 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -40,7 +40,6 @@ import Data.Abstract.Evaluatable import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package -import qualified Data.Abstract.ScopeGraph as ScopeGraph import Data.Abstract.Value.Abstract as Abstract import Data.Abstract.Value.Concrete as Concrete (Value, ValueError (..), runBoolean, runFunction, runValueErrorWith)