diff --git a/bench/Evaluation.hs b/bench/Evaluation.hs deleted file mode 100644 index 58e215a919..0000000000 --- a/bench/Evaluation.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Evaluation (benchmarks) where - -import Analysis.Project -import Control.Carrier.Parse.Simple -import Data.Abstract.Evaluatable -import Data.Bifunctor -import Data.Blob.IO (readBlobFromPath) -import qualified Data.Duration as Duration -import Data.Graph.Algebraic (topologicalSort) -import qualified Data.Language as Language -import Data.Proxy -import Gauge.Main -import Parsing.Parser -import Semantic.Config (defaultOptions) -import Semantic.Graph -import Semantic.Task (TaskSession (..), runTask, withOptions) -import Semantic.Util -import System.Path (()) -import qualified System.Path as Path -import qualified System.Path.PartClass as Path.PartClass - --- Duplicating this stuff from Util to shut off the logging - -callGraphProject' :: ( Language.SLanguage lang - , HasPrelude lang - , Path.PartClass.AbsRel ar - ) - => TaskSession - -> Proxy lang - -> Path.File ar - -> IO (Either String ()) -callGraphProject' session proxy path - | Just (SomeParser parser) <- parserForLanguage analysisParsers lang = fmap (bimap show (const ())) . runTask session $ do - blob <- readBlobFromPath (Path.toAbsRel path) - package <- fmap snd <$> runParse (Duration.fromSeconds 10) (parsePackage parser (Project (Path.toAbsRel (Path.takeDirectory path)) [blob] lang [])) - modules <- topologicalSort <$> runImportGraphToModules proxy package - runCallGraph proxy False modules package - | otherwise = error $ "Analysis not supported for: " <> show lang - where lang = Language.reflect proxy - -callGraphProject proxy paths = withOptions defaultOptions $ \ config logger statter -> - callGraphProject' (TaskSession config "" False logger statter) proxy paths - -evaluateProject proxy path - | Just (SomeParser parser) <- parserForLanguage analysisParsers lang = withOptions defaultOptions $ \ config logger statter -> - fmap (const ()) . justEvaluating =<< evaluateProject' (TaskSession config "" False logger statter) proxy parser [Path.toString path] - | otherwise = error $ "Analysis not supported for: " <> show lang - where lang = Language.reflect proxy - -pyEval :: Path.RelFile -> Benchmarkable -pyEval p = nfIO $ evaluateProject (Proxy @'Language.Python) (Path.relDir "bench/bench-fixtures/python" p) - -rbEval :: Path.RelFile -> Benchmarkable -rbEval p = nfIO $ evaluateProject (Proxy @'Language.Ruby) (Path.relDir "bench/bench-fixtures/ruby" p) - -pyCall :: Path.RelFile -> Benchmarkable -pyCall p = nfIO $ callGraphProject (Proxy @'Language.Python) (Path.relDir "bench/bench-fixtures/python/" p) - -rbCall :: Path.RelFile -> Benchmarkable -rbCall p = nfIO $ callGraphProject (Proxy @'Language.Ruby) (Path.relDir "bench/bench-fixtures/ruby" p) - -benchmarks :: Benchmark -benchmarks = bgroup "evaluation" - [ bgroup "python" [ bench "assignment" . pyEval $ Path.relFile "simple-assignment.py" - , bench "function def" . pyEval $ Path.relFile "function-definition.py" - , bench "if + function calls" . pyCall . Path.relFile $ "if-statement-functions.py" - , bench "call graph" $ pyCall . Path.relFile $ "if-statement-functions.py" - ] - , bgroup "ruby" [ bench "assignment" . rbEval $ Path.relFile "simple-assignment.rb" - , bench "function def" . rbEval . Path.relFile $ "function-definition.rb" - , bench "if + function calls" . rbCall $ Path.relFile "if-statement-functions.rb" - , bench "call graph" $ rbCall $ Path.relFile "if-statement-functions.rb" - ] - ] diff --git a/bench/Main.hs b/bench/Main.hs index c1f6ca1fff..c26905c0dd 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,11 +1,9 @@ module Main (main) where import Gauge -import qualified Evaluation import qualified Tagging main :: IO () main = defaultMain [ Tagging.benchmarks - , Evaluation.benchmarks ] diff --git a/semantic.cabal b/semantic.cabal index 11ad129843..037fb66f64 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -82,34 +82,7 @@ common executable-flags library import: haskell, dependencies hs-source-dirs: src - exposed-modules: - -- Analyses & term annotations - Analysis.Abstract.Caching.FlowInsensitive - , Analysis.Abstract.Caching.FlowSensitive - , Analysis.Abstract.Collecting - , Analysis.Abstract.Dead - , Analysis.Abstract.Graph - , Analysis.Abstract.Tracing - , Analysis.ConstructorName - , Analysis.CyclomaticComplexity - , Analysis.HasTextElement - -- Semantic assignment - , Assigning.Assignment - , Assigning.Assignment.Table - -- Control structures & interfaces for abstract interpretation - , Control.Abstract - , Control.Abstract.Context - , Control.Abstract.Evaluator - , Control.Abstract.Heap - , Control.Abstract.Hole - , Control.Abstract.Modules - , Control.Abstract.Primitive - , Control.Abstract.PythonPackage - , Control.Abstract.Roots - , Control.Abstract.ScopeGraph - , Control.Abstract.Value - -- Carriers - , Control.Carrier.Parse.Measured + exposed-modules: Control.Carrier.Parse.Measured , Control.Carrier.Parse.Simple -- Effects , Control.Effect.Interpose @@ -117,27 +90,6 @@ library , Control.Effect.REPL , Control.Effect.Sum.Project , Control.Effect.Timeout - -- Datatypes for abstract interpretation - , Data.Abstract.Address.Hole - , Data.Abstract.Address.Monovariant - , Data.Abstract.Address.Precise - , Data.Abstract.BaseError - , Data.Abstract.Declarations - , Data.Abstract.Evaluatable - , Data.Abstract.FreeVariables - , Data.Abstract.AccessControls.Class - , Data.Abstract.AccessControls.Instances - , Data.Abstract.Heap - , Data.Abstract.Live - , Data.Abstract.Module - , Data.Abstract.ModuleTable - , Data.Abstract.Number - , Data.Abstract.Package - , Data.Abstract.Path - , Data.Abstract.ScopeGraph - , Data.Abstract.Value.Abstract - , Data.Abstract.Value.Concrete - , Data.Abstract.Value.Type -- General datatype definitions & generic algorithms , Data.AST , Data.Blob @@ -148,57 +100,18 @@ library , Data.Flag , Data.Functor.Classes.Generic , Data.Graph.Algebraic - , Data.Graph.ControlFlowVertex , Data.Handle , Data.History - , Data.ImportPath , Data.Language , Data.Map.Monoidal , Data.Maybe.Exts - , Data.Quieterm , Data.Semigroup.App , Data.Scientific.Exts , Data.Term - -- À la carte syntax types - , Data.Syntax - , Data.Syntax.Comment - , Data.Syntax.Declaration - , Data.Syntax.Directive - , Data.Syntax.Expression - , Data.Syntax.Literal - , Data.Syntax.Statement - , Data.Syntax.Type - -- Language-specific grammar/syntax types, & assignments - , Language.Go.Assignment - , Language.Go.Syntax - , Language.Go.Term - , Language.Go.Type - , Language.Ruby.Assignment - , Language.Ruby.Syntax - , Language.Ruby.Term - , Language.TSX.Assignment - , Language.TSX.Syntax - , Language.TSX.Syntax.JSX - , Language.TSX.Term - , Language.TypeScript.Assignment - , Language.TypeScript.Resolution - , Language.TypeScript.Syntax - , Language.TypeScript.Syntax.Import - , Language.TypeScript.Syntax.JavaScript - , Language.TypeScript.Syntax.TypeScript - , Language.TypeScript.Syntax.Types - , Language.TypeScript.Term - , Language.PHP.Syntax - , Language.PHP.Term - , Language.Python.Assignment - , Language.Python.Syntax - , Language.Python.Term , Numeric.Exts -- Parser glue , Parsing.Parser , Parsing.TreeSitter - -- High-level flow & operational functionality (logging, stats, etc.) - , Semantic.Analysis -- API , Semantic.Api , Semantic.Api.Bridge @@ -209,7 +122,6 @@ library , Semantic.Config , Semantic.Distribute , Semantic.Env - , Semantic.Graph , Semantic.IO , Semantic.Resolution , Semantic.Task @@ -224,7 +136,6 @@ library , Semantic.Version -- Serialization , Serializing.Format - , Serializing.SExpression , Serializing.SExpression.Precise -- Custom Prelude autogen-modules: Paths_semantic @@ -298,24 +209,13 @@ test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - other-modules: Analysis.Go.Spec - , Analysis.PHP.Spec - , Analysis.Python.Spec - , Analysis.Ruby.Spec - , Analysis.TypeScript.Spec - , Assigning.Assignment.Spec - , Control.Abstract.Evaluator.Spec - , Data.Abstract.Path.Spec - , Data.Abstract.Name.Spec - , Data.Functor.Classes.Generic.Spec + ghc-options: -Werror + other-modules: Data.Functor.Classes.Generic.Spec , Data.Functor.Listable , Data.Graph.Spec - , Data.Mergeable , Data.Language.Spec , Data.Scientific.Spec , Data.Semigroup.App.Spec - , Data.Term.Spec - , Graphing.Calls.Spec , Integration.Spec , Numeric.Spec , Parsing.Spec @@ -368,8 +268,7 @@ benchmark benchmarks hs-source-dirs: bench type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: Evaluation - , Tagging + other-modules: Tagging ghc-options: -static build-depends: base , algebraic-graphs diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs deleted file mode 100644 index 8951cd22ef..0000000000 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -module Analysis.Abstract.Caching.FlowInsensitive -( cachingTerms -, convergingModules -, caching -) where - -import Control.Carrier.Fresh.Strict -import Control.Carrier.NonDet.Church -import Control.Carrier.Reader -import Control.Carrier.State.Strict -import Data.Bifunctor -import Data.Foldable -import Data.Functor.Classes -import Data.Maybe.Exts -import Data.Semilattice.Lower -import Data.Set (Set) - -import Control.Abstract -import Data.Abstract.Module -import Data.Map.Monoidal as Monoidal hiding (empty) - --- | Look up the set of values for a given configuration in the in-cache. -consultOracle :: (Has (Reader (Cache term address value)) sig m, Ord address, Ord term, Ord value) - => Configuration term address - -> Evaluator term address value m (Set value) -consultOracle configuration = asks (fromMaybe mempty . cacheLookup configuration) - --- | Run an action with the given in-cache. -withOracle :: Has (Reader (Cache term address value)) sig m - => Cache term address value - -> Evaluator term address value m a - -> Evaluator term address value m a -withOracle cache = local (const cache) - - --- | Look up the set of values for a given configuration in the out-cache. -lookupCache :: (Has (State (Cache term address value)) sig m, Ord address, Ord term) - => Configuration term address - -> Evaluator term address value m (Maybe (Set value)) -lookupCache configuration = cacheLookup configuration <$> get - --- | Run an action, caching its result and 'Heap' under the given configuration. -cachingConfiguration :: (Has (State (Cache term address value)) sig m, Ord address, Ord term, Ord value) - => Configuration term address - -> Set value - -> Evaluator term address value m value - -> Evaluator term address value m value -cachingConfiguration configuration values action = do - modify (cacheSet configuration values) - result <- action - result <$ modify (cacheInsert configuration result) - -putCache :: Has (State (Cache term address value)) sig m - => Cache term address value - -> Evaluator term address value m () -putCache = put - --- | Run an action starting from an empty out-cache, and return the out-cache afterwards. -isolateCache :: (Has (State (Cache term address value)) sig m, Has (State (Heap address address value)) sig m) - => Evaluator term address value m a - -> Evaluator term address value m (Cache term address value, Heap address 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. -cachingTerms :: ( Has (Reader (Cache term address value)) sig m - , Has (Reader (Live address)) sig m - , Has (State (Cache term address value)) sig m - , Ord address - , Ord term - , Ord value - , Alternative m - ) - => Open (term -> Evaluator term address value m value) -cachingTerms recur term = do - c <- getConfiguration term - cached <- lookupCache c - case cached of - Just values -> scatter values - Nothing -> do - values <- consultOracle c - cachingConfiguration c values (recur term) - -convergingModules :: ( Effect sig - , Eq value - , Has Fresh sig m - , Has (Reader (Cache term address value)) sig m - , Has (Reader (Live address)) sig m - , Has (State (Cache term address value)) sig m - , Has (State (Heap address address value)) sig m - , Ord address - , Ord term - , Alternative m - ) - => (Module (Either prelude term) -> Evaluator term address value (NonDetC (FreshC m)) value) - -> (Module (Either prelude term) -> Evaluator term address value m value) -convergingModules recur m@(Module _ (Left _)) = raiseHandler (evalFresh 0 . runNonDetA) (recur m) >>= maybeM empty -convergingModules recur m@(Module _ (Right term)) = do - c <- getConfiguration term - heap <- getHeap - -- Convergence here is predicated upon an Eq instance, not α-equivalence - (cache, _) <- converge (lowerBound, heap) (\ (prevCache, _) -> isolateCache $ do - -- We need to reset fresh generation so that this invocation converges. - raiseHandler (evalFresh 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 (raiseHandler (runNonDetA @Maybe) (recur m))) - 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, Alternative m) => t value -> Evaluator term address value m value -scatter = foldMapA pure - --- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: Has (Reader (Live address)) sig m - => term - -> Evaluator term address value m (Configuration term address) -getConfiguration term = Configuration term <$> askRoots - - -caching :: Algebra sig m - => Evaluator term address value (NonDetC - (ReaderC (Cache term address value) - (StateC (Cache term address value) - m))) a - -> Evaluator term address value m (Cache term address value, [a]) -caching - = raiseHandler (runState lowerBound) - . raiseHandler (runReader lowerBound) - . fmap (toList @B) - . raiseHandler runNonDetA - -data B a = E | L a | B (B a) (B a) - deriving (Functor) - -instance Foldable B where - toList = flip go [] - where go E rest = rest - go (L a) rest = a : rest - go (B a b) rest = go a (go b rest) - - foldMap f = go - where go E = mempty - go (L a) = f a - go (B a b) = go a <> go b - - null E = True - null _ = False - -instance Traversable B where - traverse f = go - where go E = pure E - go (L a) = L <$> f a - go (B a b) = B <$> go a <*> go b - -instance Applicative B where - pure = L - E <*> _ = E - L f <*> a = fmap f a - B l r <*> a = B (l <*> a) (r <*> a) - -instance Alternative B where - empty = E - E <|> b = b - a <|> E = a - a <|> b = B a b - -instance Monad B where - return = pure - E >>= _ = E - L a >>= f = f a - B l r >>= f = B (l >>= f) (r >>= f) - - --- | 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) (Set value) } - deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address, value), Semigroup) - --- | A single point in a program’s execution. -data Configuration term address = Configuration - { configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate. - , configurationRoots :: Live address -- ^ The set of rooted addresses. - } - deriving (Eq, Ord, Show) - - --- | Look up the resulting value & 'Heap' for a given 'Configuration'. -cacheLookup :: (Ord address, Ord term) => Configuration term address -> Cache term address value -> Maybe (Set value) -cacheLookup key = Monoidal.lookup key . unCache - --- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry. -cacheSet :: (Ord address, Ord term) => Configuration term address -> Set 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 :: (Ord address, Ord term, Ord value) => Configuration term 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/Analysis/Abstract/Caching/FlowSensitive.hs b/src/Analysis/Abstract/Caching/FlowSensitive.hs deleted file mode 100644 index 530a974f4f..0000000000 --- a/src/Analysis/Abstract/Caching/FlowSensitive.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -module Analysis.Abstract.Caching.FlowSensitive -( Cache -, cachingTerms -, convergingModules -, caching -) where - -import Control.Carrier.Fresh.Strict -import Control.Carrier.NonDet.Church -import Control.Carrier.Reader -import Control.Carrier.State.Strict -import Data.Bifunctor -import Data.Foldable -import Data.Functor -import Data.Functor.Classes -import Data.Maybe.Exts -import Data.Semilattice.Lower -import Data.Set (Set) - -import Control.Abstract -import Data.Abstract.Module -import Data.Map.Monoidal as Monoidal hiding (empty) - --- | Look up the set of values for a given configuration in the in-cache. -consultOracle :: (Cacheable term address value, Has (Reader (Cache term address value)) sig m) - => Configuration term address value - -> Evaluator term address value m (Set (Cached address value)) -consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask - --- | Run an action with the given in-cache. -withOracle :: Has (Reader (Cache term address value)) sig m - => Cache term address value - -> Evaluator term address value m a - -> Evaluator term address value m 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, Has (State (Cache term address value)) sig m) - => Configuration term address value - -> Evaluator term address value m (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, Has (State (Cache term address value)) sig m, Has (State (Heap address address value)) sig m) - => Configuration term address value - -> Set (Cached address value) - -> Evaluator term address value m value - -> Evaluator term address value m value -cachingConfiguration configuration values action = do - modify (cacheSet configuration values) - result <- Cached <$> action <*> getHeap - cachedValue result <$ modify (cacheInsert configuration result) - -putCache :: Has (State (Cache term address value)) sig m - => Cache term address value - -> Evaluator term address value m () -putCache = put - --- | Run an action starting from an empty out-cache, and return the out-cache afterwards. -isolateCache :: Has (State (Cache term address value)) sig m - => Evaluator term address value m a - -> Evaluator term address value m (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 - , Has (Reader (Cache term address value)) sig m - , Has (Reader (Live address)) sig m - , Has (State (Cache term address value)) sig m - , Has (State (Heap address address value)) sig m - , Alternative m - ) - => Open (term -> Evaluator term address value m value) -cachingTerms recur term = do - c <- getConfiguration term - cached <- lookupCache c - case cached of - Just pairs -> scatter pairs - Nothing -> do - pairs <- consultOracle c - cachingConfiguration c pairs (recur term) - -convergingModules :: ( Cacheable term address value - , Effect sig - , Has Fresh sig m - , Has (Reader (Cache term address value)) sig m - , Has (Reader (Live address)) sig m - , Has (State (Cache term address value)) sig m - , Has (State (Heap address address value)) sig m - , Alternative m - ) - => (Module (Either prelude term) -> Evaluator term address value (NonDetC (FreshC m)) value) - -> (Module (Either prelude term) -> Evaluator term address value m value) -convergingModules recur m@(Module _ (Left _)) = raiseHandler (evalFresh 0 . runNonDetA) (recur m) >>= maybeM empty -convergingModules recur m@(Module _ (Right term)) = do - c <- getConfiguration term - -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge lowerBound (\ prevCache -> isolateCache $ do - putHeap (configurationHeap c) - -- We need to reset fresh generation so that this invocation converges. - raiseHandler (evalFresh 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 (raiseHandler (runNonDetA @Maybe) (recur m))) - 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, Has (State (Heap address address value)) sig m, Alternative m) - => t (Cached address value) - -> Evaluator term address value m value -scatter = foldMapA (\ (Cached value heap') -> putHeap heap' $> value) - --- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: (Has (Reader (Live address)) sig m, Has (State (Heap address address value)) sig m) - => term - -> Evaluator term address value m (Configuration term address value) -getConfiguration term = Configuration term <$> askRoots <*> getHeap - - -caching :: Monad m - => Evaluator term address value ( NonDetC - (ReaderC (Cache term address value) - (StateC (Cache term address value) - m))) a - -> Evaluator term address value m (Cache term address value, [a]) -caching - = raiseHandler (runState lowerBound) - . raiseHandler (runReader lowerBound) - . raiseHandler runNonDetA - - --- | 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. - , configurationHeap :: Heap address address value -- ^ The heap of values. - } - deriving (Eq, Ord, Show) - -data Cached address value = Cached - { cachedValue :: value - , cachedHeap :: Heap address 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/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs deleted file mode 100644 index 7499775dbd..0000000000 --- a/src/Analysis/Abstract/Collecting.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Analysis.Abstract.Collecting -( providingLiveSet -) where - -import Control.Abstract -import Control.Carrier.Reader -import Data.Semilattice.Lower - -providingLiveSet :: Evaluator term address value (ReaderC (Live address) m) a -> Evaluator term address value m a -providingLiveSet = raiseHandler (runReader lowerBound) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs deleted file mode 100644 index d58cc65632..0000000000 --- a/src/Analysis/Abstract/Dead.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -module Analysis.Abstract.Dead -( Dead(..) -, revivingTerms -, killingModules -, providingDeadSet -) where - -import Control.Abstract -import Control.Carrier.State.Strict -import Data.Abstract.Module -import Data.Functor.Foldable -import Data.Semigroup.Reducer as Reducer -import Data.Semilattice.Lower -import Data.Set (Set, delete) - --- | A set of “dead” (unreachable) terms. -newtype Dead term = Dead { unDead :: Set term } - deriving (Eq, Foldable, Lower, Monoid, Ord, Semigroup, Show) - -deriving instance Ord term => Reducer term (Dead term) - --- | Update the current 'Dead' set. -killAll :: (Has (State (Dead term)) sig m) => Dead term -> Evaluator term address value m () -killAll = put - --- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Has (State (Dead term)) sig m, Ord term) => term -> Evaluator term address value m () -revive t = modify (Dead . delete t . unDead) - --- | Compute the set of all subterms recursively. -subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term -subterms term = term `cons` para (foldMap (uncurry cons)) term - - -revivingTerms :: ( Has (State (Dead term)) sig m - , Ord term - ) - => Open (term -> Evaluator term address value m a) -revivingTerms recur term = revive term *> recur term - -killingModules :: ( Foldable (Base term) - , Has (State (Dead term)) sig m - , Ord term - , Recursive term - ) - => Open (Module term -> Evaluator term address value m a) -killingModules recur m = killAll (subterms (moduleBody m)) *> recur m - -providingDeadSet :: Evaluator term address value (StateC (Dead term) (Evaluator term address value m)) a - -> Evaluator term address value m (Dead term, a) -providingDeadSet = runState lowerBound . runEvaluator diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs deleted file mode 100644 index 0e85943741..0000000000 --- a/src/Analysis/Abstract/Graph.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -module Analysis.Abstract.Graph -( Graph(..) -, ControlFlowVertex(..) -, moduleVertex -, unknownModuleVertex -, style -, appendGraph -, variableDefinition -, moduleInclusion -, packageInclusion -, graphingTerms -, graphingPackages -, graphingModules -, graphingModuleInfo -, graphing -) where - -import Algebra.Graph.Export.Dot hiding (vertexName) -import Control.Abstract hiding (Function (..)) -import Control.Algebra -import Control.Carrier.Reader -import Control.Carrier.State.Strict -import Control.Effect.Sum.Project -import Data.Abstract.BaseError -import Data.Abstract.Module (Module (moduleInfo), ModuleInfo (..)) -import Data.ByteString.Builder -import Data.Graph.Algebraic -import Data.Graph.ControlFlowVertex -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Text.Encoding as T -import Source.Loc - -style :: Style ControlFlowVertex Builder -style = (defaultStyle (T.encodeUtf8Builder . vertexIdentifier)) - { vertexAttributes = vertexAttributes - , edgeAttributes = edgeAttributes - } - where vertexAttributes Package{} = [ "style" := "dashed", "shape" := "box" ] - vertexAttributes Module{} = [ "style" := "dotted, rounded", "shape" := "box" ] - vertexAttributes UnknownModule{} = [ "style" := "dotted, rounded", "shape" := "box", "color" := "red", "fontcolor" := "red" ] - vertexAttributes (Variable n _ s) = [ "label" := T.encodeUtf8Builder (n <> " (Variable)"), "tooltip" := T.encodeUtf8Builder (showSpan s), "style" := "rounded", "shape" := "box" ] - vertexAttributes (Method n _ s) = [ "label" := T.encodeUtf8Builder (n <> " (Method)"), "tooltip" := T.encodeUtf8Builder (showSpan s) , "style" := "rounded", "shape" := "box" ] - vertexAttributes (Function n _ s) = [ "label" := T.encodeUtf8Builder (n <> " (Function)"), "tooltip" := T.encodeUtf8Builder (showSpan s), "style" := "rounded", "shape" := "box" ] - edgeAttributes Module{} Module{} = [ "len" := "5.0", "label" := "imports" ] - edgeAttributes Module{} UnknownModule{} = [ "len" := "5.0", "label" := "imports" ] - edgeAttributes Package{} Module{} = [ "len" := "5.0", "style" := "dashed" ] - edgeAttributes Variable{} Module{} = [ "len" := "5.0", "color" := "blue", "label" := "refers to symbol defined in" ] - edgeAttributes _ Module{} = [ "len" := "5.0", "color" := "blue", "label" := "defined in" ] - edgeAttributes Method{} Variable{} = [ "len" := "2.0", "color" := "green", "label" := "calls" ] - edgeAttributes Function{} Variable{} = [ "len" := "2.0", "color" := "green", "label" := "calls" ] - edgeAttributes Module{} Function{} = [ "len" := "2.0", "color" := "red", "label" := "defines" ] - edgeAttributes Module{} Method{} = [ "len" := "2.0", "color" := "red", "label" := "defines" ] - edgeAttributes Module{} _ = [ "len" := "2.0", "color" := "green", "label" := "calls" ] - edgeAttributes Variable{} Function{} = [ "len" := "2.0", "color" := "blue", "label" := "references" ] - edgeAttributes Variable{} Method{} = [ "len" := "2.0", "color" := "blue", "label" := "references" ] - edgeAttributes _ _ = [] - - --- | Add vertices to the graph for evaluated identifiers. -graphingTerms :: ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State (Graph ControlFlowVertex)) sig m - , Has (State (Map (Slot address) ControlFlowVertex)) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ControlFlowVertex) sig m - , VertexDeclaration term - , Ord address - ) - => Open (term Loc -> Evaluator (term Loc) address value m a) -graphingTerms recur term = do - definedInModule <- currentModule - case toVertex definedInModule term of - Just (v@Function{}, name) -> recurWithContext v name - Just (v@Method{}, name) -> recurWithContext v name - Just (v@Variable{}, name) -> do - variableDefinition v - slot <- lookupSlot (Declaration name) - defined <- gets (Map.lookup slot) - maybe (pure ()) (appendGraph . connect (vertex v) . vertex) defined - recur term - _ -> recur term - where - recurWithContext v name = do - variableDefinition v - moduleInclusion v - local (const v) $ do - valRef <- recur term - slot <- lookupSlot (Declaration name) - modify (Map.insert slot v) - pure valRef - --- | Add vertices to the graph for evaluated modules and the packages containing them. -graphingPackages :: ( Has (Reader PackageInfo) sig m - , Has (State (Graph ControlFlowVertex)) sig m - , Has (Reader ControlFlowVertex) sig m - ) - => Open (Module term -> m a) -graphingPackages recur m = - let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m) - --- | Add vertices to the graph for imported modules. -graphingModules :: ( Has (Reader ModuleInfo) sig m - , Has (State (Graph ControlFlowVertex)) sig m - , Has (Reader ControlFlowVertex) sig m - ) - => (Module body -> Evaluator term address value (EavesdropC address value m) a) - -> (Module body -> Evaluator term address value m a) -graphingModules recur m = do - let v = moduleVertex (moduleInfo m) - appendGraph (vertex v) - local (const v) $ - eavesdrop (recur m) $ \case - Load path _ -> includeModule path - Lookup path _ -> includeModule path - _ -> pure () - where - -- NB: path is null for Languages like Ruby that have module imports that require concrete value semantics. - includeModule path - = let info = moduleInfo m - in moduleInclusion (moduleVertex (ModuleInfo path (moduleLanguage info) (moduleOid info))) - --- | Add vertices to the graph for imported modules. -graphingModuleInfo :: ( Has (Reader ModuleInfo) sig m - , Has (State (Graph ModuleInfo)) sig m - ) - => (Module body -> Evaluator term address value (EavesdropC address value m) a) - -> (Module body -> Evaluator term address value m a) -graphingModuleInfo recur m = do - let info = moduleInfo m - appendGraph (vertex info) - eavesdrop (recur m) $ \case - Load path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path (moduleLanguage info) (moduleOid info))) . vertex - Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path (moduleLanguage info) (moduleOid info))) . vertex - _ -> pure () - -eavesdrop :: Evaluator term address value (EavesdropC address value m) a - -> (forall x . Modules address value m x -> Evaluator term address value m ()) - -> Evaluator term address value m a -eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f)) m - -newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address value m x -> m ()) -> m a) - deriving (Alternative, Applicative, Functor, Monad) via (ReaderC (forall x . Modules address value m x -> m ()) m) - -runEavesdropC :: (forall x . Modules address value m x -> m ()) -> EavesdropC address value m a -> m a -runEavesdropC f (EavesdropC m) = m f - -instance (Has (Modules address value) sig m, Project (Modules address value) sig, Applicative m) => Algebra sig (EavesdropC address value m) where - alg op - | Just alg <- prj op = EavesdropC (\ handler -> let eff' = hmap (runEavesdropC handler) alg in handler eff' *> send eff') - | otherwise = EavesdropC (\ handler -> alg (hmap (runEavesdropC handler) op)) - --- | Add an edge from the current package to the passed vertex. -packageInclusion :: ( Has (Reader PackageInfo) sig m - , Has (State (Graph ControlFlowVertex)) sig m - ) - => ControlFlowVertex - -> m () -packageInclusion v = do - p <- currentPackage - appendGraph (vertex (packageVertex p) `connect` vertex v) - --- | Add an edge from the current module to the passed vertex. -moduleInclusion :: ( Has (Reader ModuleInfo) sig m - , Has (State (Graph ControlFlowVertex)) sig m - ) - => ControlFlowVertex - -> m () -moduleInclusion v = do - m <- currentModule - appendGraph (vertex (moduleVertex m) `connect` vertex v) - --- | Add an edge from the passed variable name to the context it originated within. -variableDefinition :: ( Has (State (Graph ControlFlowVertex)) sig m - , Has (Reader ControlFlowVertex) sig m - ) - => ControlFlowVertex - -> m () -variableDefinition var = do - context <- ask - appendGraph (vertex context `connect` vertex var) - -appendGraph :: Has (State (Graph v)) sig m => Graph v -> m () -appendGraph = modify . (<>) - - -graphing :: Algebra sig m - => Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex) - (StateC (Graph ControlFlowVertex) - m)) result - -> Evaluator term address value m (Graph ControlFlowVertex, result) -graphing = raiseHandler $ runState mempty . fmap snd . runState lowerBound diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs deleted file mode 100644 index 06bd470fba..0000000000 --- a/src/Analysis/Abstract/Tracing.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Analysis.Abstract.Tracing -( tracingTerms -, tracing -) where - -import Control.Abstract hiding (trace) -import Control.Carrier.Writer.Strict -import Data.Semigroup.Reducer as Reducer - --- | Trace analysis. --- --- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -tracingTerms :: ( Has (State (Heap address address value)) sig m - , Has (Writer (trace (Configuration term address value))) sig m - , Reducer (Configuration term address value) (trace (Configuration term address value)) - ) - => trace (Configuration term address value) - -> Open (term -> Evaluator term address value m a) -tracingTerms proxy recur term = getConfiguration term >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term - -trace :: Has (Writer (trace (Configuration term address value))) sig m - => trace (Configuration term address value) - -> Evaluator term address value m () -trace = tell - -tracing :: Monoid (trace (Configuration term address value)) - => Evaluator term address value (WriterC (trace (Configuration term address value)) (Evaluator term address value m)) a - -> Evaluator term address value m (trace (Configuration term address value), a) -tracing = runWriter . runEvaluator - - --- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: Has (State (Heap address address value)) sig m - => term - -> Evaluator term address value m (Configuration term address value) -getConfiguration term = Configuration term <$> 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. - , configurationHeap :: Heap address address value -- ^ The heap of values. - } - deriving (Eq, Ord, Show) diff --git a/src/Analysis/ConstructorName.hs b/src/Analysis/ConstructorName.hs deleted file mode 100644 index 529bb3f82c..0000000000 --- a/src/Analysis/ConstructorName.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Analysis.ConstructorName -( ConstructorName(..) -) where - -import Data.Proxy -import Data.Sum -import Data.Term -import GHC.Generics - --- | A typeclass to retrieve the name of the data constructor for a value. --- --- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap; see also src/Analysis/Declaration.hs for discussion of the details of the mechanism. -class ConstructorName syntax where - constructorName :: syntax a -> String - -instance (ConstructorNameStrategy syntax ~ strategy, ConstructorNameWithStrategy strategy syntax) => ConstructorName syntax where - constructorName = constructorNameWithStrategy (Proxy :: Proxy strategy) - -instance Apply ConstructorName fs => ConstructorNameWithStrategy 'Custom (Sum fs) where - constructorNameWithStrategy _ = apply @ConstructorName constructorName - -instance ConstructorNameWithStrategy 'Custom [] where - constructorNameWithStrategy _ _ = "Statements" - -instance (ConstructorName syntax) => ConstructorNameWithStrategy 'Custom (TermF syntax ann) where - constructorNameWithStrategy _ = constructorName . termFOut - -data Strategy = Default | Custom - -type family ConstructorNameStrategy syntax where - ConstructorNameStrategy (Sum _) = 'Custom - ConstructorNameStrategy [] = 'Custom - ConstructorNameStrategy (TermF _ _) = 'Custom - ConstructorNameStrategy _ = 'Default - -class ConstructorNameWithStrategy (strategy :: Strategy) syntax where - constructorNameWithStrategy :: proxy strategy -> syntax a -> String - -instance (Generic1 syntax, GConstructorName (Rep1 syntax)) => ConstructorNameWithStrategy 'Default syntax where - constructorNameWithStrategy _ = gconstructorName . from1 - - -class GConstructorName f where - gconstructorName :: f a -> String - -instance GConstructorName f => GConstructorName (M1 D c f) where - gconstructorName = gconstructorName . unM1 - -instance (GConstructorName f, GConstructorName g) => GConstructorName (f :+: g) where - gconstructorName (L1 l) = gconstructorName l - gconstructorName (R1 r) = gconstructorName r - -instance Constructor c => GConstructorName (M1 C c f) where - gconstructorName = conName diff --git a/src/Analysis/HasTextElement.hs b/src/Analysis/HasTextElement.hs deleted file mode 100644 index 3d59d5a0f5..0000000000 --- a/src/Analysis/HasTextElement.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Analysis.HasTextElement -( HasTextElement(..) -) where - -import Data.Sum -import Data.Proxy -import qualified Data.Syntax.Literal as Literal - -class HasTextElement syntax where - isTextElement :: syntax a -> Bool - -instance (TextElementStrategy syntax ~ strategy, HasTextElementWithStrategy strategy syntax) => HasTextElement syntax where - isTextElement = isTextElementWithStrategy (Proxy :: Proxy strategy) - -class CustomHasTextElement syntax where - customIsTextElement :: syntax a -> Bool - -instance CustomHasTextElement Literal.TextElement where - customIsTextElement _ = True - -instance Apply HasTextElement fs => CustomHasTextElement (Sum fs) where - customIsTextElement = apply @HasTextElement isTextElement - -data Strategy = Default | Custom - -class HasTextElementWithStrategy (strategy :: Strategy) syntax where - isTextElementWithStrategy :: proxy strategy -> syntax a -> Bool - -type family TextElementStrategy syntax where - TextElementStrategy Literal.TextElement = 'Custom - TextElementStrategy (Sum _) = 'Custom - TextElementStrategy _ = 'Default - -instance HasTextElementWithStrategy 'Default syntax where - isTextElementWithStrategy _ _ = False - -instance CustomHasTextElement syntax => HasTextElementWithStrategy 'Custom syntax where - isTextElementWithStrategy _ = customIsTextElement diff --git a/src/Assigning/Assignment.hs b/src/Assigning/Assignment.hs deleted file mode 100644 index 31ad9a65c9..0000000000 --- a/src/Assigning/Assignment.hs +++ /dev/null @@ -1,426 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} --- | Assignment of AST onto some other structure (typically terms). --- --- Parsing yields an AST represented as a Rose tree labelled with symbols in the language’s grammar and source locations (byte Range and Span). An Assignment represents a (partial) map from AST nodes onto some other structure; in essence, it’s a parser that operates over trees. (For our purposes, this structure is typically Terms annotated with source locations.) Assignments are able to match based on symbol, sequence, and hierarchy; thus, in @x = y@, both @x@ and @y@ might have the same symbol, @Identifier@, the left can be assigned to a variable declaration, while the right can be assigned to a variable reference. --- --- Assignments can be any of the following primitive rules: --- --- 1. 'symbol' rules match a node against a specific symbol in the source language’s grammar; they succeed iff a) there is a current node, and b) its symbol is equal to the argument symbol. Matching a 'symbol' rule does not advance past the current node, meaning that you can match a node against a symbol and also e.g. match against the node’s 'children'. This also means that some care must be taken, as repeating a symbol with 'many' or 'some' (see below) will never advance past the current node and could therefore loop forever. --- --- 2. 'location' rules always succeed, and produce the current node’s Loc (byte Range and Span). If there is no current node (i.e. if matching has advanced past the root node or past the last child node when operating within a 'children' rule), the location is instead the end of the most recently matched node, specified as a zero-width Range and Span. 'location' rules do not advance past the current node, meaning that you can both match a node’s 'location' and other properties. --- --- 3. 'source' rules succeed whenever there is a current node (i.e. matching has not advanced past the root node or the last child node when operating within a 'children' rule), and produce its source as a ByteString. 'source' is intended to match leaf nodes such as e.g. comments. 'source' rules advance past the current node. --- --- 4. 'children' rules apply their argument (an assignment) to the children of the current node, succeeding iff a) there is a current node, b) the argument assignment matches the children, and c) there are no (regular) nodes left over (see below re: tokens), producing the result of matching the argument assignment against the children. 'children' rules can match a node with no child nodes if their argument can successfully match at the end of input. --- --- 5. Via the 'Alternative' instance, 'empty' assignments always fail. This can be used (in combination with the 'Monad' instance) to (for example) fail if a 'source' assignment produces an ill-formatted ByteString. However, see below re: committed choice. --- --- 6. Via the 'Applicative' instance, 'pure' (or via the 'Monad' instance, 'pure') assignments always succeed, producing the passed value. They do not advance past the current node. In combination with the 'Alternative' instance, 'pure' can provide default values when optional syntax is not present in the AST. --- --- Assignments can further be combined in a few different ways: --- --- 1. The 'Functor' instance maps values from the AST (Loc, ByteString, etc.) into another structure. --- --- 2. The 'Applicative' instance assigns sequences of (sibling) AST nodes in order, as well as providing 'pure' assignments (see above). Most assignments of a single piece of syntax consist of an 'Applicative' chain of assignments. --- --- 3. The 'Alternative' instance chooses between a set of assignments, as well as providing 'empty' assignments (see above). See below re: committed choice for best practices for efficiency & error reporting when it comes to assigning multiple alternatives. Most high-level assignments (e.g. “declaration” or “statement” assignments) consist of choices among two or more 'Applicative' chains of assignments, mirroring the structure of the parser’s choices. The 'Alternative' instance also enables repetitions via the 'many' (≥ 0 repetitions) and 'some' (≥ 1 repetition) methods. Finally, the 'optional' function uses the 'Alternative' instance to assign a value in 'Maybe', succeeding with 'Nothing' when unmatched. --- --- 4. The 'Monad' instance allows assignments to depend on the results of earlier assignments. In general, most assignments should not be written using the 'Monad' instance; however, some specific situations require it, e.g. assigning 'x += y' to be equivalent to 'x = x + y'. --- --- --- == Best practices --- --- Because of their flexibility, the same assignment can often be written in multiple different ways. The following best practices should ensure efficient assignment with clear error messages for ill-formed AST. --- --- === Committed choice --- --- Assignments can represent alternatives as either committed or uncommitted choices, both written with '<|>'. “Committed” in this context means that a failure in one of the alternatives will not result in backtracking followed by an attempt of one of the other alternatives; thus, committed choice is more efficient. (By the same token, it enables much better error messages since backtracking erases most of the relevant context.) Committed choices are constructed via the following rules: --- --- 1. 'empty' is dropped from choices. --- --- 2. 'symbol' rules construct a committed choice (with only a single alternative). --- --- 3. 'fmap' (and by extension '<$>' and '<$') of a committed choice is a committed choice. --- --- 4. '<*>' (and by extension '*>' and '<*') with a committed choice on the left is a committed choice. --- --- 5. '>>=' (and by extension '>>', '=<<', and '<<') of a committed choice is a committed choice. It may be helpful to think of this and the above rule for '<*>' as “sequences starting with committed choices remain committed choices.” --- --- 6. '<|>' of two committed choices is a committed choice. --- --- Finally, if a given choice is not a committed choice, it is an uncommitted choice. --- --- Distilling the above, the rule of thumb is to always start an assignment for a given piece of syntax with either a 'symbol' rule or an 'fmap' over a 'symbol' rule. When assigning multiple pieces of syntax, place any known uncommitted choices at the (rightmost) end of the chain; '<|>' is left-associative, so this guarantees that you’re adding at most one uncommitted choice on top of the ones already present. --- --- === Matching tokens --- --- AST symbols are classified by their 'symbolType' as either 'Regular', 'Anonymous', or 'Auxiliary'. 'Auxiliary' never appears in ASTs; 'Regular' is for the symbols of explicitly named productions in the grammar, and 'Anonymous' is for unnamed productions of content such as tokens. Most of the time, assignments are only concerned with the named productions, and thus will be using 'Regular' symbols. Therefore, when matching a committed choice of all-'Regular' symbols, nodes with 'Anonymous' symbols will be skipped. However, in some cases grammars don’t provide a named symbol for e.g. every kind of infix operator, and thus the only way to differentiate between them is by means of a 'symbol' rule for an 'Anonymous' token. In these cases, and before every other kind of assignment, the 'Anonymous' nodes will not be skipped so that matching can succeed. --- --- Therefore, in addition to the rule of thumb for committed choices (see above), try to match 'Regular' symbols up front, and only match 'Anonymous' ones in the middle of a chain. That will ensure that you don’t have to make redundant effort to explicitly skip 'Anonymous' nodes ahead of multiple alternatives, and can instead rely on them being automatically skipped except when explicitly required. -module Assigning.Assignment --- Types -( Assignment -, L.Loc(..) --- Combinators -, Alternative(..) -, MonadError(..) -, MonadFail(..) -, location -, symbol -, rawSource -, source -, children -, advance -, choice -, token -, manyThrough -, getLocals -, putLocals --- Results -, Error(..) -, nodeError -, firstSet --- Running -, assign -, runAssignment --- Implementation details (for testing) -, State(..) -, makeState -, module Parsers -) where - -import qualified Assigning.Assignment.Table as Table -import Control.Applicative -import Control.Monad -import Control.Monad.Except (MonadError (..)) -import Data.AST -import Data.Bifunctor -import Data.ByteString (ByteString) -import Data.Error -import Data.Foldable -import Data.Function -import Data.Ix -import Data.List.NonEmpty (NonEmpty (..), nonEmpty) -import Data.Maybe -import Data.Semigroup -import Data.Term -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8') -import GHC.Stack -import Prelude hiding (fail) -import qualified Source.Loc as L -import Source.Range as Range -import qualified Source.Source as Source -import Source.Span as Span -import Text.Parser.Combinators as Parsers hiding (choice) -import TreeSitter.Language - --- | Assignment from an AST with some set of 'symbol's onto some other value. --- --- This is essentially a parser. -type Assignment grammar = Freer (Tracing (AssignmentF grammar)) - -data AssignmentF grammar a where - End :: AssignmentF grammar () - Loc :: AssignmentF grammar L.Loc - Source :: AssignmentF grammar ByteString - Children :: Assignment grammar a -> AssignmentF grammar a - Choose :: Table.Table grammar (Assignment grammar a) -> Maybe (Assignment grammar a) -> Maybe (Error (Either String grammar) -> Assignment grammar a) -> AssignmentF grammar a - Many :: Assignment grammar a -> AssignmentF grammar [a] - Alt :: [a] -> AssignmentF grammar a - Label :: Assignment grammar a -> String -> AssignmentF grammar a - Fail :: String -> AssignmentF grammar a - GetLocals :: AssignmentF grammar [Text] - PutLocals :: [Text] -> AssignmentF grammar () - -data Tracing f a where - Tracing :: { tracingCallSite :: Maybe (String, SrcLoc), runTracing :: f a } -> Tracing f a - -assignmentCallSite :: Assignment grammar a -> Maybe (String, SrcLoc) -assignmentCallSite (Tracing site _ `Then` _) = site -assignmentCallSite _ = Nothing - -tracing :: HasCallStack => f a -> Tracing f a -tracing f = case getCallStack callStack of - _ : site : _ -> Tracing (Just site) f - _ -> Tracing Nothing f - --- | Zero-width production of the current location. --- --- If assigning at the end of input or at the end of a list of children, the location will be returned as an empty Range and Span at the current offset. Otherwise, it will be the Range and Span of the current node. -location :: Assignment grammar L.Loc -location = tracing Loc `Then` pure - -getLocals :: HasCallStack => Assignment grammar [Text] -getLocals = tracing GetLocals `Then` pure - -putLocals :: HasCallStack => [Text] -> Assignment grammar () -putLocals l = tracing (PutLocals l) `Then` pure - --- | Zero-width match of a node with the given symbol, producing the current node’s location. -symbol :: (Enum grammar, HasCallStack) => grammar -> Assignment grammar L.Loc -symbol s = tracing (Choose (Table.singleton s location) Nothing Nothing) `Then` pure - --- | A rule to produce a node’s source as a ByteString. --- You probably want to use 'source', unless you're throwing away the result. -rawSource :: HasCallStack => Assignment grammar ByteString -rawSource = tracing Source `Then` pure - --- | A rule to produce a node's source as Text. Fails if the node's source can't be parsed as UTF-8. -source :: HasCallStack => Assignment grammar Text -source = fmap decodeUtf8' rawSource >>= either (\e -> fail ("UTF-8 decoding failed: " <> show e)) pure - --- | Match a node by applying an assignment to its children. -children :: HasCallStack => Assignment grammar a -> Assignment grammar a -children child = tracing (Children child) `Then` pure - --- | Advance past the current node. -advance :: HasCallStack => Assignment grammar () -advance = () <$ source - --- | Construct a committed choice table from a list of alternatives. Use this to efficiently select between long lists of rules. -choice :: (Enum grammar, Ix grammar, HasCallStack) => [Assignment grammar a] -> Assignment grammar a -choice [] = empty -choice alternatives - | null choices = asum alternatives - | otherwise = tracing (Choose (Table.fromListWith (<|>) choices) ((`Then` id) . tracing . Alt . toList <$> nonEmpty atEnd) (mergeHandlers handlers)) `Then` pure - where (choices, atEnd, handlers) = foldMap toChoices alternatives - toChoices :: (Enum grammar, Ix grammar) => Assignment grammar a -> ([(grammar, Assignment grammar a)], [Assignment grammar a], [Error (Either String grammar) -> Assignment grammar a]) - toChoices rule = case rule of - Tracing _ (Choose t a h) `Then` continue -> (Table.toPairs (fmap (>>= continue) t), toList ((>>= continue) <$> a), toList ((continue <=<) <$> h)) - Tracing _ (Many child) `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], []) - Tracing _ (Label child _) `Then` _ -> let (c, _, _) = toChoices child in (fmap (rule <$) c, [rule], []) - Tracing _ (Alt as) `Then` continue -> foldMap (toChoices . continue) as - _ -> ([], [rule], []) - - mergeHandlers [] = Nothing - mergeHandlers hs = Just (\ err -> asum (hs <*> [err])) - --- | Match and advance past a node with the given symbol. -token :: (Enum grammar, HasCallStack) => grammar -> Assignment grammar L.Loc -token s = symbol s <* advance - - --- | Match the first operand until the second operand matches, returning both results. Like 'manyTill', but returning the terminal value. -manyThrough :: Alternative m => m a -> m b -> m ([a], b) -manyThrough step stop = go - where go = (,) [] <$> stop <|> first . (:) <$> step <*> go - - -nodeError :: CallStack -> [Either String grammar] -> Node grammar -> Error (Either String grammar) -nodeError cs expected n@Node{..} = Error (nodeSpan n) expected (Just (Right nodeSymbol)) cs - - -firstSet :: (Enum grammar, Ix grammar) => Assignment grammar a -> [grammar] -firstSet = iterFreer (\ _ (Tracing _ assignment) -> case assignment of - Choose table _ _ -> Table.tableAddresses table - Label child _ -> firstSet child - _ -> []) . ([] <$) - - --- | Run an assignment over an AST exhaustively. -assign :: Symbol grammar - => Source.Source -- ^ The source for the parse tree. - -> Assignment grammar a -- ^ The 'Assignment to run. - -> AST grammar -- ^ The root of the ast. - -> Either (Error String) a -- ^ 'Either' an 'Error' or an assigned value. -assign source assignment ast = bimap (fmap (either id show)) fst (runAssignment source assignment (makeState [ast])) -{-# INLINE assign #-} - --- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively. -runAssignment :: forall grammar a . (Symbol grammar) - => Source.Source -- ^ The source for the parse tree. - -> Assignment grammar a -- ^ The 'Assignment' to run. - -> State grammar -- ^ The current state. - -> Either (Error (Either String grammar)) (a, State grammar) -- ^ 'Either' an 'Error' or an assigned value & updated state. -runAssignment source = \ assignment state -> go assignment state >>= requireExhaustive (assignmentCallSite assignment) - -- Note: We explicitly bind source above in order to ensure that the where clause can close over them; they don’t change through the course of the run, so holding one reference is sufficient. On the other hand, we don’t want to accidentally capture the assignment and state in the where clause, since they change at every step—and capturing when you meant to shadow is an easy mistake to make, & results in hard-to-debug errors. Binding them in a lambda avoids that problem while also being easier to follow than a pointfree definition. - where go :: Assignment grammar result -> State grammar -> Either (Error (Either String grammar)) (result, State grammar) - go assignment = iterFreer run ((pure .) . (,) <$> assignment) - {-# INLINE go #-} - - run :: (x -> State grammar -> Either (Error (Either String grammar)) (result, State grammar)) - -> Tracing (AssignmentF grammar) x - -> State grammar - -> Either (Error (Either String grammar)) (result, State grammar) - run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes) - where atNode (Term (In node f)) = case runTracing t of - Loc -> yield (nodeLocation node) state - GetLocals -> yield stateLocals state - PutLocals l -> yield () (state { stateLocals = l }) - Source -> yield (Source.bytes (Source.slice source (nodeByteRange node))) (advanceState state) - Children child -> do - (a, state') <- go child state { stateNodes = toList f, stateCallSites = maybe id (:) (tracingCallSite t) stateCallSites } >>= requireExhaustive (tracingCallSite t) - yield a (advanceState state' { stateNodes = stateNodes, stateCallSites = stateCallSites }) - Choose choices _ handler | Just choice <- Table.lookup (nodeSymbol node) choices -> (go choice state `catchError` maybe throwError (flip go state .) handler) >>= uncurry yield - _ -> anywhere (Just node) - - anywhere node = case runTracing t of - GetLocals -> yield stateLocals state - PutLocals l -> yield () (state { stateLocals = l }) - End -> requireExhaustive (tracingCallSite t) ((), state) >>= uncurry yield - Loc -> yield (L.Loc (Range stateOffset stateOffset) (Span statePos statePos)) state - Many rule -> fix (\ recur state -> (go rule state >>= \ (a, state') -> first (a:) <$> if state == state' then pure ([], state') else recur state') `catchError` const (pure ([], state))) state >>= uncurry yield - Alt (a:as) -> sconcat (flip yield state <$> a:|as) - Label child label -> go child state `catchError` (\ err -> throwError err { errorExpected = [Left label] }) >>= uncurry yield - Fail s -> throwError ((makeError' node) { errorActual = Just (Left s) }) - Choose _ (Just atEnd) _ | Nothing <- node -> go atEnd state >>= uncurry yield - _ -> Left (makeError' node) - - state@State{..} = case (runTracing t, initialState) of - (Choose table _ _, State { stateNodes = Term (In node _) : _ }) | symbolType (nodeSymbol node) /= Regular, symbols@(_:_) <- Table.tableAddresses table, all ((== Regular) . symbolType) symbols -> skipTokens initialState - _ -> initialState - expectedSymbols = firstSet (t `Then` pure) - assignmentStack = maybe emptyCallStack (fromCallSiteList . pure) (tracingCallSite t) - makeError' = maybe - (Error (Span statePos statePos) (fmap Right expectedSymbols) Nothing assignmentStack) - (nodeError assignmentStack (fmap Right expectedSymbols)) - -requireExhaustive :: Symbol grammar => Maybe (String, SrcLoc) -> (result, State grammar) -> Either (Error (Either String grammar)) (result, State grammar) -requireExhaustive callSite (a, state) = - let state' = skipTokens state - stack = fromCallSiteList (maybe id (:) callSite (stateCallSites state)) - in case stateNodes state' of - [] -> Right (a, state') - Term (In node _) : _ -> Left (nodeError stack [] node) - -skipTokens :: Symbol grammar => State grammar -> State grammar -skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . nodeSymbol . termAnnotation) (stateNodes state) } - --- | Advances the state past the current (head) node (if any), dropping it off stateNodes, and updating stateOffset & statePos to its end; or else returns the state unchanged. -advanceState :: State grammar -> State grammar -advanceState state@State{..} - | Term (In node _) : rest <- stateNodes = State (Range.end (nodeByteRange node)) (Span.end (nodeSpan node)) stateCallSites rest stateLocals - | otherwise = state - --- | State kept while running 'Assignment's. -data State grammar = State - { stateOffset :: {-# UNPACK #-} !Int -- ^ The offset into the Source thus far reached, measured in bytes. - , statePos :: {-# UNPACK #-} !Pos -- ^ The (1-indexed) line/column position in the Source thus far reached. - , stateCallSites :: ![(String, SrcLoc)] -- ^ The symbols & source locations of the calls thus far. - , stateNodes :: ![AST grammar] -- ^ The remaining nodes to assign. Note that 'children' rules recur into subterms, and thus this does not necessarily reflect all of the terms remaining to be assigned in the overall algorithm, only those “in scope.” - , stateLocals :: ![Text] -- Special state necessary for the Ruby assignment. When we refactor Assignment to use effects we should pull this out into Language.Ruby.Assignment. - } - deriving (Eq, Show) - -makeState :: [AST grammar] -> State grammar -makeState ns = State 0 (Pos 1 1) [] ns [] - - --- Instances - -instance (Enum grammar, Ix grammar) => Alternative (Assignment grammar) where - empty :: HasCallStack => Assignment grammar a - empty = tracing (Alt []) `Then` pure - - (<|>) :: forall a. Assignment grammar a -> Assignment grammar a -> Assignment grammar a - Return a <|> _ = Return a - l@(Tracing cs _ `Then` _) <|> r@Return{} = Tracing cs (Alt [l, r]) `Then` id - l@(Tracing callSiteL la `Then` continueL) <|> r@(Tracing callSiteR ra `Then` continueR) = go callSiteL la continueL callSiteR ra continueR - where go :: forall l r . Maybe (String, SrcLoc) -> AssignmentF grammar l -> (l -> Assignment grammar a) -> Maybe (String, SrcLoc) -> AssignmentF grammar r -> (r -> Assignment grammar a) -> Assignment grammar a - go callSiteL la continueL callSiteR ra continueR = case (la, ra) of - (Fail _, _) -> r - (Alt [], _) -> r - (_, Alt []) -> l - (Alt ls, Alt rs) -> alternate (Alt ((Left <$> ls) <> (Right <$> rs))) - (Alt ls, _) -> rebuild (Alt ((continueL <$> ls) <> pure r)) id - (_, Alt rs) -> rebuild (Alt (pure l <> (continueR <$> rs))) id - _ -> rebuild (Alt [l, r]) id - where alternate :: AssignmentF grammar (Either l r) -> Assignment grammar a - alternate a = rebuild a (either continueL continueR) - rebuild :: AssignmentF grammar x -> (x -> Assignment grammar a) -> Assignment grammar a - rebuild a c = Tracing (callSiteL <|> callSiteR) a `Then` c - - many :: HasCallStack => Assignment grammar a -> Assignment grammar [a] - many a = tracing (Many a) `Then` pure - -instance MonadFail (Assignment grammar) where - fail :: HasCallStack => String -> Assignment grammar a - fail s = tracing (Fail s) `Then` pure - -instance (Enum grammar, Ix grammar, Show grammar) => Parsing (Assignment grammar) where - try = id - - () :: HasCallStack => Assignment grammar a -> String -> Assignment grammar a - a s = tracing (Label a s) `Then` pure - - unexpected :: String -> Assignment grammar a - unexpected = fail - - eof :: HasCallStack => Assignment grammar () - eof = tracing End `Then` pure - - notFollowedBy :: Show a => Assignment grammar a -> Assignment grammar () - notFollowedBy a = (a >>= unexpected . show) <|> pure () - -instance (Enum grammar, Ix grammar, Show grammar) => MonadError (Error (Either String grammar)) (Assignment grammar) where - throwError err = fail (show err) - - catchError rule handler = iterFreer (\ continue (Tracing cs assignment) -> case assignment of - Choose choices atEnd Nothing -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just handler)) `Then` pure - Choose choices atEnd (Just onError) -> Tracing cs (Choose (fmap (>>= continue) choices) (fmap (>>= continue) atEnd) (Just (\ err -> (onError err >>= continue) <|> handler err))) `Then` pure - _ -> Tracing cs assignment `Then` ((`catchError` handler) . continue)) (fmap pure rule) - - --- Freer - -data Freer f a where - Return :: a -> Freer f a - Then :: f x -> (x -> Freer f a) -> Freer f a - -infixl 1 `Then` - -instance Functor (Freer f) where - fmap f = go - where go (Return result) = Return (f result) - go (Then step yield) = Then step (go . yield) - {-# INLINE go #-} - {-# INLINE fmap #-} - -instance Applicative (Freer f) where - pure = Return - {-# INLINE pure #-} - - Return f <*> param = fmap f param - Then action yield <*> param = Then action ((<*> param) . yield) - {-# INLINE (<*>) #-} - - Return _ *> a = a - Then r f *> a = Then r ((*> a) . f) - {-# INLINE (*>) #-} - - Return a <* b = b *> Return a - Then r f <* a = Then r ((<* a) . f) - {-# INLINE (<*) #-} - -instance Monad (Freer f) where - return = pure - {-# INLINE return #-} - - Return a >>= f = f a - Then r f >>= g = Then r (g <=< f) - {-# INLINE (>>=) #-} - - (>>) = (*>) - {-# INLINE (>>) #-} - --- | Tear down a 'Freer' 'Monad' using iteration with an explicit continuation. --- --- This is analogous to 'iter' with a continuation for the interior values, and is therefore suitable for defining interpreters for GADTs/types lacking a 'Functor' instance. -iterFreer :: (forall x. (x -> a) -> f x -> a) -> Freer f a -> a -iterFreer algebra = go - where go (Return result) = result - go (Then action continue) = algebra (go . continue) action - {-# INLINE go #-} -{-# INLINE iterFreer #-} diff --git a/src/Assigning/Assignment/Table.hs b/src/Assigning/Assignment/Table.hs deleted file mode 100644 index 5a3f0d2942..0000000000 --- a/src/Assigning/Assignment/Table.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE RecordWildCards #-} -module Assigning.Assignment.Table -( Table(tableAddresses) -, singleton -, fromListWith -, toPairs -, lookup -) where - -import Data.Bifunctor -import Data.Functor.Classes -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import Data.Monoid.Generic -import Data.Traversable -import GHC.Generics (Generic) -import Prelude hiding (lookup) - -data Table i a = Table { tableAddresses :: [i], tableBranches :: IntMap a } - deriving (Eq, Foldable, Functor, Show, Traversable, Generic) - deriving Monoid via GenericMonoid (Table i a) - -singleton :: Enum i => i -> a -> Table i a -singleton i a = Table [i] (IntMap.singleton (fromEnum i) a) - -fromListWith :: Enum i => (a -> a -> a) -> [(i, a)] -> Table i a -fromListWith with assocs = Table (toEnum <$> IntSet.toList (IntSet.fromList (fromEnum . fst <$> assocs))) (IntMap.fromListWith with (first fromEnum <$> assocs)) - -toPairs :: Enum i => Table i a -> [(i, a)] -toPairs Table{..} = first toEnum <$> IntMap.toList tableBranches - - -lookup :: Enum i => i -> Table i a -> Maybe a -lookup i = IntMap.lookup (fromEnum i) . tableBranches - -instance (Enum i, Semigroup a) => Semigroup (Table i a) where - (Table i1 b1) <> (Table i2 b2) = Table (i1 <> i2) (IntMap.unionWith (<>) b1 b2) - -instance (Enum i, Show i) => Show1 (Table i) where - liftShowsPrec spA slA d t = showsBinaryWith showsPrec (const (liftShowList spA slA)) "Table" d (tableAddresses t) (toPairs t) diff --git a/src/Control/Abstract.hs b/src/Control/Abstract.hs deleted file mode 100644 index 8c6f8837e4..0000000000 --- a/src/Control/Abstract.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Control.Abstract ( - module X -) where - -import Control.Abstract.Context as X -import Control.Abstract.Evaluator as X -import Control.Abstract.Heap as X -import Control.Abstract.Hole as X -import Control.Abstract.Modules as X -import Control.Abstract.Primitive as X -import Control.Abstract.Roots as X -import Control.Abstract.ScopeGraph as X -import Control.Abstract.Value as X diff --git a/src/Control/Abstract/Context.hs b/src/Control/Abstract/Context.hs deleted file mode 100644 index ca8b826d9a..0000000000 --- a/src/Control/Abstract/Context.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Control.Abstract.Context -( ModuleInfo -, currentModule -, withCurrentModule -, PackageInfo -, currentPackage -, withCurrentPackage -, Span -, currentSpan -, withCurrentSpan -, modifyChildSpan -, withCurrentCallStack -) where - -import Control.Effect.Reader -import Control.Effect.State -import Data.Abstract.Module -import Data.Abstract.Package -import Data.Maybe -import GHC.Stack -import Source.Span - --- | Get the currently evaluating 'ModuleInfo'. -currentModule :: (Has (Reader ModuleInfo) sig m) => m ModuleInfo -currentModule = ask - --- | Run an action with a locally-replaced 'ModuleInfo'. -withCurrentModule :: Has (Reader ModuleInfo) sig m => ModuleInfo -> m a -> m a -withCurrentModule = local . const - --- | Get the currently evaluating 'PackageInfo'. -currentPackage :: Has (Reader PackageInfo) sig m => m PackageInfo -currentPackage = ask - --- | Run an action with a locally-replaced 'PackageInfo'. -withCurrentPackage :: Has (Reader PackageInfo) sig m => PackageInfo -> m a -> m a -withCurrentPackage = local . const - --- | Get the 'Span' of the currently-evaluating term (if any). -currentSpan :: Has (Reader Span) sig m => m Span -currentSpan = ask - --- | Run an action with a locally-replaced 'Span'. -withCurrentSpan :: Has (Reader Span) sig m => Span -> m a -> m a -withCurrentSpan = local . const - -modifyChildSpan :: Has (State Span) sig m => Span -> m a -> m a -modifyChildSpan span m = m <* put span - --- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'. -withCurrentSrcLoc :: (Has (Reader ModuleInfo) sig m, Has (Reader Span) sig m) => SrcLoc -> m a -> m a -withCurrentSrcLoc loc = withCurrentModule (moduleInfoFromSrcLoc loc) . withCurrentSpan (spanFromSrcLoc loc) - --- | Run an action with locally replaced 'ModuleInfo' & 'Span' derived from the Haskell call stack. --- --- This is suitable for contextualizing builtins & other functionality intended for use from client code but defined in Haskell source. -withCurrentCallStack :: (Has (Reader ModuleInfo) sig m, Has (Reader Span) sig m) => CallStack -> m a -> m a -withCurrentCallStack = maybe id (withCurrentSrcLoc . snd) . listToMaybe . getCallStack diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs deleted file mode 100644 index 44729d6f53..0000000000 --- a/src/Control/Abstract/Evaluator.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeOperators, UndecidableInstances #-} -module Control.Abstract.Evaluator - ( Evaluator(..) - , raiseHandler - , Open - -- * Effects - , Return(..) - , earlyReturn - , catchReturn - , runReturn - , LoopControl(..) - , throwBreak - , throwContinue - , throwAbort - , catchLoopControl - , runLoopControl - , module X - ) where - -import Control.Algebra -import Control.Carrier.Error.Either -import Control.Effect.Error as X -import Control.Effect.Fresh as X -import Control.Effect.NonDet as X -import Control.Effect.Reader as X -import Control.Effect.Resumable as X -import Control.Effect.State as X -import Control.Effect.Trace as X -import Control.Monad.IO.Class -import Data.Coerce - --- | An 'Evaluator' is a thin wrapper around a monad with (phantom) type parameters for the address, term, and value types. --- --- These parameters enable us to constrain the types of effects using them s.t. we can avoid both ambiguous types when they aren’t mentioned outside of the context, and lengthy, redundant annotations on the use sites of functions employing these effects. --- --- These effects will typically include the environment, heap, module table, etc. effects necessary for evaluation of modules and terms, but may also include any other effects so long as they’re eventually handled. -newtype Evaluator term address value m a = Evaluator { runEvaluator :: m a } - deriving (Alternative, Applicative, Functor, Monad, MonadIO) - -instance Algebra sig m => Algebra sig (Evaluator term address value m) where - alg = Evaluator . alg . handleCoercible - --- | Raise a handler on monads into a handler on 'Evaluator's over those monads. -raiseHandler :: (m a -> n b) - -> Evaluator term address value m a - -> Evaluator term address value n b -raiseHandler = coerce - - --- | An open-recursive function. -type Open a = a -> a - - --- Effects - --- | An effect for explicitly returning out of a function/method body. -newtype Return value = Return { unReturn :: value } - deriving (Eq, Ord, Show) - -earlyReturn :: Has (Throw (Return value)) sig m - => value - -> Evaluator term address value m value -earlyReturn = throwError . Return - -catchReturn :: Has (Catch (Return value)) sig m - => Evaluator term address value m value - -> Evaluator term address value m value -catchReturn = flip catchError (\ (Return value) -> pure value) - -runReturn :: Algebra sig m - => Evaluator term address value (ErrorC (Return value) m) value - -> Evaluator term address value m value -runReturn = raiseHandler $ fmap (either unReturn id) . runError - - --- | Effects for control flow around loops (breaking and continuing). -data LoopControl value - = Break value - | Continue value - | Abort - deriving (Eq, Ord, Show) - -unLoopControl :: LoopControl value -> value -unLoopControl = \case - Break v -> v - Continue v -> v - Abort -> error "unLoopControl: Abort" - -throwBreak :: Has (Error (LoopControl value)) sig m - => value - -> Evaluator term address value m value -throwBreak = throwError . Break - -throwContinue :: Has (Error (LoopControl value)) sig m - => value - -> Evaluator term address value m value -throwContinue = throwError . Continue - -throwAbort :: forall term address sig m value a . Has (Error (LoopControl value)) sig m - => Evaluator term address value m a -throwAbort = throwError (Abort @value) - -catchLoopControl :: Has (Error (LoopControl value)) sig m - => Evaluator term address value m a - -> (LoopControl value -> Evaluator term address value m a) - -> Evaluator term address value m a -catchLoopControl = catchError - -runLoopControl :: Algebra sig m - => Evaluator term address value (ErrorC (LoopControl value) m) value - -> Evaluator term address value m value -runLoopControl = raiseHandler $ fmap (either unLoopControl id) . runError diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs deleted file mode 100644 index d34f1feaba..0000000000 --- a/src/Control/Abstract/Heap.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Control.Abstract.Heap -( Heap -, HeapError(..) -, Slot(..) -, Position(..) -, Live -, getHeap -, putHeap -, putSlotDeclarationScope -, alloc -, dealloc -, maybeLookupDeclaration -, lookupSlot -, lookupDeclarationFrame -, deref -, assign -, newFrame -, CurrentFrame(..) -, currentFrame -, lookupFrame -, withScopeAndFrame -, withLexicalScopeAndFrame -, withChildFrame -, define -, withFrame --- * Garbage collection -, gc --- * Effects -, Allocator(..) -, Deref(..) -, runDeref -, DerefC(..) -, AddressError(..) -, runHeapError -, runAddressError -, runAddressErrorWith -, throwAddressError -, runHeapErrorWith -, throwHeapError -, insertFrameLink -, scopeLookup -) where - -import Analysis.Name -import Control.Abstract.Context (withCurrentCallStack) -import Control.Abstract.Evaluator -import Control.Abstract.Roots -import Control.Abstract.ScopeGraph hiding (ScopeError (..)) -import Control.Abstract.ScopeGraph (ScopeError) -import Control.Algebra -import Control.Carrier.Resumable.Either (SomeError (..)) -import qualified Control.Carrier.Resumable.Either as Either -import qualified Control.Carrier.Resumable.Resume as With -import Data.Abstract.BaseError -import Data.Abstract.Heap (Heap, Position (..)) -import qualified Data.Abstract.Heap as Heap -import Data.Abstract.Live -import Data.Abstract.Module (ModuleInfo) -import Data.Abstract.ScopeGraph (Kind (..), Path (..), putDeclarationScopeAtPosition) -import Data.Functor.Classes -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe.Exts -import Data.Semilattice.Lower -import Data.Set (Set) -import GHC.Generics (Generic1) -import GHC.Stack -import Source.Span (Pos (..), Span, point) - - --- | Evaluates an action locally the scope and frame of the given frame address. -withScopeAndFrame :: ( Ord address - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (State (Heap address address value)) sig m - ) - => address - -> Evaluator term address value m a - -> Evaluator term address value m a -withScopeAndFrame address action = do - scope <- scopeLookup address - withScope scope (withFrame address action) - --- | Evaluates an action locally the scope and frame of the given frame address. -withLexicalScopeAndFrame :: ( Ord address - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Allocator address) sig m - , Has Fresh sig m - ) - => Evaluator term address value m a - -> Evaluator term address value m a -withLexicalScopeAndFrame action = do - currentScope' <- currentScope - currentFrame' <- currentFrame - let (scopeEdges, frameEdges) = (Map.singleton Lexical [ currentScope' ], Map.singleton Lexical (Map.singleton currentScope' currentFrame')) - scope <- newScope scopeEdges - frame <- newFrame scope frameEdges - withScopeAndFrame frame action - --- | Lookup a scope address for a given frame address. -scopeLookup :: ( Ord address - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (State (Heap address address value)) sig m - - ) - => address - -> Evaluator term address value m address -scopeLookup address = maybeM (throwHeapError (LookupAddressError address)) =<< Heap.scopeLookup address <$> getHeap - -getHeap :: Has (State (Heap address address value)) sig m => Evaluator term address value m (Heap address address value) -getHeap = get - --- | Set the heap. -putHeap :: Has (State (Heap address address value)) sig m => Heap address address value -> Evaluator term address value m () -putHeap = put - --- | Update the heap. -modifyHeap :: Has (State (Heap address address value)) sig m => (Heap address address value -> Heap address address value) -> Evaluator term address value m () -modifyHeap = modify - -newtype CurrentFrame address = CurrentFrame { unCurrentFrame :: address } - --- | Retrieve the heap. -currentFrame :: Has (Reader (CurrentFrame address)) sig m - => Evaluator term address value m address -currentFrame = asks unCurrentFrame - - --- | Inserts a new frame into the heap with the given scope and links. -newFrame :: ( Has (Allocator address) sig m - , Has Fresh sig m - , Has (State (Heap address address value)) sig m - , Ord address - ) - => address - -> Map EdgeLabel (Map address address) - -> Evaluator term address value m address -newFrame scope links = do - name <- gensym - address <- alloc name - modifyHeap (Heap.newFrame scope address links) - pure address - --- | Evaluates the action within the frame of the given frame address. -withFrame :: Has (Reader (CurrentFrame address)) sig m - => address - -> Evaluator term address value m a -- Not sure about this `sig` here (substituting `sig` for `effects`) - -> Evaluator term address value m a -withFrame address = local (const (CurrentFrame address)) - --- | Define a declaration and assign the value of an action in the current frame. -define :: ( HasCallStack - , Has (Deref value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Ord address - ) - => Declaration - -> Relation - -> AccessControl - -> Evaluator term address value m value - -> Evaluator term address value m () -define declaration rel accessControl def = withCurrentCallStack callStack $ do - -- TODO: This span is still wrong. - declare declaration rel accessControl (point (Pos 1 1)) Unknown Nothing - slot <- lookupSlot declaration - value <- def - assign slot value - --- | Associate an empty child scope with a declaration and then locally evaluate the body within an associated frame. -withChildFrame :: ( Has (Allocator address) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has Fresh sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Ord address - ) - => Declaration - -> (address -> Evaluator term address value m a) - -> Evaluator term address value m a -withChildFrame declaration body = do - scope <- newPreludeScope mempty - putDeclarationScope declaration scope - frame <- newFrame scope mempty - withScopeAndFrame frame (body frame) - --- | Dereference the given address in the heap, or fail if the address is uninitialized. -deref :: ( Has (Deref value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (AddressError address value))) sig m - , Has (State (Heap address address value)) sig m - , Ord address - ) - => Slot address - -> Evaluator term address value m value -deref slot@Slot{..} = do - maybeSlotValue <- gets (Heap.getSlotValue slot) - slotValue <- maybeM (throwAddressError (UnallocatedSlot slot)) maybeSlotValue - eff <- send $ DerefCell slotValue pure - maybeM (throwAddressError $ UninitializedSlot slot) eff - -putSlotDeclarationScope :: ( Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Ord address - ) - => Slot address - -> Maybe address - -> Evaluator term address value m () -putSlotDeclarationScope Slot{..} assocScope = do - scopeAddress <- scopeLookup frameAddress - modify (putDeclarationScopeAtPosition scopeAddress position assocScope) - - -maybeLookupDeclaration :: ( Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Ord address - ) - => Declaration - -> Evaluator term address value m (Maybe (Slot address)) -maybeLookupDeclaration decl = do - path <- maybeLookupScopePath decl - case path of - Just path -> do - frameAddress <- lookupFrameAddress path - pure (Just (Slot frameAddress (Heap.pathPosition path))) - Nothing -> pure Nothing - -lookupSlot :: ( Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Ord address - ) - => Declaration - -> Evaluator term address value m (Slot address) -lookupSlot decl = do - path <- lookupScopePath decl - frameAddress <- lookupFrameAddress path - pure (Slot frameAddress (Heap.pathPosition path)) - -lookupDeclarationFrame :: ( Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Ord address - ) - => Declaration - -> Evaluator term address value m address -lookupDeclarationFrame decl = do - path <- lookupScopePath decl - lookupFrameAddress path - -lookupFrame :: ( Has (State (Heap address address value)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Ord address - ) - => address - -> Evaluator term address value m (Heap.Frame address address value) -lookupFrame address = do - heap <- getHeap - maybeM (throwHeapError (LookupFrameError address)) (Heap.frameLookup address heap) - --- | Follow a path through the heap and return the frame address associated with the declaration. -lookupFrameAddress :: ( Has (State (Heap address address value)) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Ord address - ) - => Path address - -> Evaluator term address value m address -lookupFrameAddress path = go path =<< currentFrame - where - go path address = case path of - Hole -> throwHeapError (LookupLinkError path) - DPath _ _ -> pure address - p@(EPath edge nextScopeAddress path') -> do - linkMap <- frameLinks address - let frameAddress = do - scopeMap <- Map.lookup edge linkMap - Map.lookup nextScopeAddress scopeMap - maybe (throwHeapError $ LookupLinkError p) (go path') frameAddress - -frameLinks :: ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (State (Heap address address value)) sig m - , Ord address - ) - => address - -> Evaluator term address value m (Map EdgeLabel (Map address address)) -- TODO: Change this to Map scope address -frameLinks address = maybeM (throwHeapError (LookupLinksError address)) . Heap.frameLinks address =<< getHeap - - -insertFrameLink :: ( Has (Reader (CurrentFrame address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (State (Heap address address value)) sig m - , Ord address - ) - => EdgeLabel - -> Map address address - -> Evaluator term address value m () -insertFrameLink label linkMap = do - frameAddress <- currentFrame - heap <- getHeap - currentFrame <- maybeM (throwHeapError (LookupFrameError frameAddress)) (Heap.frameLookup frameAddress heap) - let newCurrentFrame = currentFrame - { Heap.links = Map.alter (\val -> val <> Just linkMap) label (Heap.links currentFrame) } - modify (Heap.insertFrame frameAddress newCurrentFrame) - - --- | Write a value to the given frame address in the 'Heap'. -assign :: ( Has (Deref value) sig m - , Has (State (Heap address address value)) sig m - , Ord address - ) - => Slot address - -> value - -> Evaluator term address value m () -assign addr value = do - heap <- getHeap - cell <- send (AssignCell value (fromMaybe lowerBound (Heap.getSlotValue addr heap)) pure) - putHeap (Heap.setSlot addr cell heap) - -dealloc :: ( Has (State (Heap address address value)) sig m - , Ord address - ) - => Slot address - -> Evaluator term address value m () -dealloc addr = modifyHeap (Heap.deleteSlot addr) - - --- Garbage collection - --- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set. -gc :: ( Has (State (Heap address address value)) sig m - , Ord address - , Ord value - , ValueRoots address value - ) - => Live address -- ^ The set of addresses to consider rooted. - -> Evaluator term address value m () -gc roots = modifyHeap (Heap.heapRestrict <*> reachable roots) - --- | Compute the set of addresses reachable from a given root set in a given heap. -reachable :: ( Ord address - , Ord value - , ValueRoots address value - ) - => Live address -- ^ The set of root addresses. - -> Heap address address value -- ^ The heap to trace addresses through. - -> Live address -- ^ The set of addresses reachable from the root set. -reachable roots heap = go mempty roots - where go seen set = case liveSplit set of - Nothing -> seen - Just (a, as) -> go (liveInsert a seen) $ case Heap.heapLookupAll a heap of - Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen - _ -> seen - - --- Effects - -data Deref value (m :: * -> *) k - = DerefCell (Set value) (Maybe value -> m k) - | AssignCell value (Set value) (Set value -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Deref value) -instance Effect (Deref value) - -runDeref :: Evaluator term address value (DerefC address value m) a - -> Evaluator term address value m a -runDeref = raiseHandler runDerefC - -newtype DerefC address value m a = DerefC { runDerefC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - - - -data HeapError address resume where - CurrentFrameError :: HeapError address address - LookupAddressError :: address -> HeapError address address - LookupFrameError :: address -> HeapError address (Heap.Frame address address value) - LookupLinksError :: address -> HeapError address (Map EdgeLabel (Map address address)) - LookupLinkError :: Path address -> HeapError address address - -deriving instance Eq address => Eq (HeapError address resume) -deriving instance Show address => Show (HeapError address resume) -instance Show address => Show1 (HeapError address) where - liftShowsPrec _ _ = showsPrec - -instance Eq address => Eq1 (HeapError address) where - liftEq _ CurrentFrameError CurrentFrameError = True - liftEq _ (LookupAddressError a) (LookupAddressError b) = a == b - liftEq _ (LookupLinksError a) (LookupLinksError b) = a == b - liftEq _ (LookupLinkError a) (LookupLinkError b) = a == b - liftEq _ (LookupFrameError a) (LookupFrameError b) = a == b - liftEq _ _ _ = False - -throwHeapError :: ( Has (Resumable (BaseError (HeapError address))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - ) - => HeapError address resume - -> Evaluator term address value m resume -throwHeapError = throwBaseError - -runHeapError :: Evaluator term address value (Either.ResumableC (BaseError (HeapError address)) m) a - -> Evaluator term address value m (Either (SomeError (BaseError (HeapError address))) a) -runHeapError = raiseHandler Either.runResumable - -runHeapErrorWith :: (forall resume. (BaseError (HeapError address)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (With.ResumableC (BaseError (HeapError address)) m) a - -> Evaluator term address value m a -runHeapErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) - -data AddressError address value resume where - UnallocatedSlot :: Slot address -> AddressError address value (Set value) - UninitializedSlot :: Slot address -> AddressError address value value - -deriving instance Eq address => Eq (AddressError address value resume) -deriving instance Show address => Show (AddressError address value resume) -instance Show address => Show1 (AddressError address value) where - liftShowsPrec _ _ = showsPrec -instance Eq address => Eq1 (AddressError address value) where - liftEq _ (UninitializedSlot a) (UninitializedSlot b) = a == b - liftEq _ (UnallocatedSlot a) (UnallocatedSlot b) = a == b - liftEq _ _ _ = False - -throwAddressError :: ( Has (Resumable (BaseError (AddressError address body))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - ) - => AddressError address body resume - -> Evaluator term address value m resume -throwAddressError = throwBaseError - -runAddressError :: Evaluator term address value (Either.ResumableC (BaseError (AddressError address value)) m) a - -> Evaluator term address value m (Either (SomeError (BaseError (AddressError address value))) a) -runAddressError = raiseHandler Either.runResumable - -runAddressErrorWith :: (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (With.ResumableC (BaseError (AddressError address value)) m) a - -> Evaluator term address value m a -runAddressErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) diff --git a/src/Control/Abstract/Hole.hs b/src/Control/Abstract/Hole.hs deleted file mode 100644 index 63913c3aca..0000000000 --- a/src/Control/Abstract/Hole.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Control.Abstract.Hole - ( module X - ) where - -import Data.Hole as X diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs deleted file mode 100644 index 8d6b04d08f..0000000000 --- a/src/Control/Abstract/Modules.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Control.Abstract.Modules -( ModuleResult -, lookupModule -, resolve -, listModulesInDir -, require -, load -, Modules(..) -, runModules -, LoadError(..) -, runLoadError -, runLoadErrorWith -, throwLoadError -, ResolutionError(..) -, runResolutionError -, runResolutionErrorWith -, throwResolutionError -, ModuleTable -) where - -import Control.Algebra -import Control.Carrier.Reader -import qualified Control.Carrier.Resumable.Either as Either -import qualified Control.Carrier.Resumable.Resume as With -import Control.Monad.IO.Class -import Data.Foldable -import Data.Functor.Classes -import Data.Maybe.Exts -import Data.Set (Set) -import qualified Data.Set as Set -import GHC.Generics (Generic1) -import Source.Span -import qualified System.Path as Path - -import Control.Abstract.Evaluator -import Data.Abstract.BaseError -import Data.Abstract.Module -import Data.Abstract.ModuleTable as ModuleTable -import Data.Language - --- | A scope address, frame address, and value ref. --- --- Partially applied, omitting the value type for type applications at * -> *. -type ModuleResult address = (,) (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 :: Has (Modules address value) sig m => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address value)) -lookupModule = sendModules . flip Lookup pure - --- | Resolve a list of module paths to a possible module table entry. -resolve :: Has (Modules address value) sig m => [Path.AbsRelFile] -> Evaluator term address value m (Maybe ModulePath) -resolve = sendModules . flip Resolve pure - -listModulesInDir :: Has (Modules address value) sig m => Path.AbsRelDir -> Evaluator term address value m [ModulePath] -listModulesInDir = sendModules . flip List pure - - --- | Require/import another module by name and return its environment and value. --- --- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. -require :: Has (Modules address value) sig m => ModulePath -> Evaluator term address value m (ModuleResult address value) -require path = lookupModule path >>= maybeM (load path) - --- | Load another module by name and return its environment and value. --- --- Always loads/evaluates. -load :: Has (Modules address value) sig m => ModulePath -> Evaluator term address value m (ModuleResult address value) -load path = sendModules (Load path pure) - - -data Modules address value (m :: * -> *) k - = Load ModulePath (ModuleResult address value -> m k) - | Lookup ModulePath (Maybe (ModuleResult address value) -> m k) - | Resolve [Path.AbsRelFile] (Maybe ModulePath -> m k) - | List Path.AbsRelDir ([ModulePath] -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Modules address value) -instance Effect (Modules address value) - - -sendModules :: Has (Modules address value) sig m - => Modules address value (Evaluator term address value m) return - -> Evaluator term address value m return -sendModules = send - -runModules :: Set ModulePath - -> Evaluator term address value (ModulesC address value m) a - -> Evaluator term address value m a -runModules paths = raiseHandler (runReader paths . runModulesC) - -newtype ModulesC address value m a = ModulesC { runModulesC :: ReaderC (Set ModulePath) m a } - deriving (Alternative, Applicative, Functor, Monad, MonadIO) - -instance ( Has (Reader (ModuleTable (Module (ModuleResult address value)))) sig m - , Has (Resumable (BaseError (LoadError address value))) sig m - ) - => Algebra (Modules address value :+: sig) (ModulesC address value m) where - alg (L op) = do - paths <- ModulesC ask - case op of - Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap moduleBody . ModuleTable.lookup name >>= k - Lookup path k -> askModuleTable >>= k . fmap moduleBody . ModuleTable.lookup path - Resolve names k -> k (find (`Set.member` paths) names) - List dir k -> k (filter ((dir ==) . Path.takeDirectory) (toList paths)) - alg (R other) = ModulesC (alg (R (handleCoercible other))) - -askModuleTable :: Has (Reader (ModuleTable (Module (ModuleResult address value)))) sig m => m (ModuleTable (Module (ModuleResult address value))) -askModuleTable = ask - - --- | 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. -data LoadError address value resume where - ModuleNotFoundError :: ModulePath -> LoadError address value (ModuleResult address value) - -deriving instance Eq (LoadError address value resume) -deriving instance Show (LoadError address value resume) -instance Show1 (LoadError address value) where - liftShowsPrec _ _ = showsPrec -instance Eq1 (LoadError address value) where - liftEq _ (ModuleNotFoundError a) (ModuleNotFoundError b) = a == b - -runLoadError :: Evaluator term address value (Either.ResumableC (BaseError (LoadError address value)) m) a - -> Evaluator term address value m (Either (Either.SomeError (BaseError (LoadError address value))) a) -runLoadError = raiseHandler Either.runResumable - -runLoadErrorWith :: (forall resume . (BaseError (LoadError address value)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (With.ResumableC (BaseError (LoadError address value)) m) a - -> Evaluator term address value m a -runLoadErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) - -throwLoadError :: Has (Resumable (BaseError (LoadError address value))) sig m - => LoadError address value resume - -> m resume -throwLoadError err@(ModuleNotFoundError name) = throwResumable $ BaseError (ModuleInfo name "Unknown" mempty) (point (Pos 1 1)) err --- TODO: Might be able to get rest of ModuleInfo from the env ^. - - --- | An error thrown when we can't resolve a module from a qualified name. -data ResolutionError resume where - NotFoundError :: Path.AbsRelFileDir -- The path that was not found. - -> [Path.AbsRelFile] -- List of paths searched that shows where semantic looked for this module. - -> Language -- Language. - -> ResolutionError ModulePath - - -- Go Lang may have its package import path as an uri like https://github.com/packagename rather than an file path - -- TODO: A typed path can be used here to represent the uri - GoImportError :: String -> ResolutionError [ModulePath] - -deriving instance Eq (ResolutionError b) -deriving instance Show (ResolutionError b) -instance Show1 ResolutionError where liftShowsPrec _ _ = showsPrec -instance Eq1 ResolutionError where - liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2 - liftEq _ (GoImportError a) (GoImportError b) = a == b - liftEq _ _ _ = False - -runResolutionError :: Evaluator term address value (Either.ResumableC (BaseError ResolutionError) m) a - -> Evaluator term address value m (Either (Either.SomeError (BaseError ResolutionError)) a) -runResolutionError = raiseHandler Either.runResumable - -runResolutionErrorWith :: (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume) - -> Evaluator term address value (With.ResumableC (BaseError ResolutionError) m) a - -> Evaluator term address value m a -runResolutionErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) - -throwResolutionError :: ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - ) - => ResolutionError resume - -> Evaluator term address value m resume -throwResolutionError = throwBaseError diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs deleted file mode 100644 index 87862b1698..0000000000 --- a/src/Control/Abstract/Primitive.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -module Control.Abstract.Primitive - ( defineClass - , defineNamespace - , defineBuiltIn - ) where - -import Analysis.Name -import Control.Abstract.Context -import Control.Abstract.Evaluator -import Control.Abstract.Heap -import Control.Abstract.ScopeGraph -import Control.Abstract.Value -import Control.Monad -import Data.Abstract.BaseError -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Map.Strict as Map -import Data.Maybe -import Data.Traversable -import GHC.Stack -import Source.Span (Pos (..), point) - -defineBuiltIn :: ( HasCallStack - , Has (Deref value) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Function term address value) sig m - , Has (Allocator address) sig m - , Has Fresh sig m - , Ord address - ) - => Declaration - -> Relation - -> AccessControl - -> BuiltIn - -> Evaluator term address value m () -defineBuiltIn declaration rel accessControl value = withCurrentCallStack callStack $ do - currentScope' <- currentScope - let lexicalEdges = Map.singleton Lexical [ currentScope' ] - associatedScope <- newPreludeScope lexicalEdges - -- TODO: This span is still wrong. - declare declaration rel accessControl (point (Pos 1 1)) ScopeGraph.Unknown (Just associatedScope) - - withScope associatedScope $ do - param <- gensym - declare (Declaration param) ScopeGraph.Gensym accessControl (point (Pos 1 1)) ScopeGraph.Unknown Nothing - - slot <- lookupSlot declaration - value <- builtIn associatedScope value - assign slot value - -defineClass :: ( HasCallStack - , Has (Allocator address) sig m - , Has (Deref value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has Fresh sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Unit value) sig m - , Ord address - ) - => Declaration - -> [Declaration] - -> Evaluator term address value m a - -> Evaluator term address value m () -defineClass declaration superclasses body = void . define declaration Default Public $ do - currentScope' <- currentScope - - superScopes <- for superclasses associatedScope - - let superclassEdges = (Superclass, ) <$> (fmap pure . catMaybes $ superScopes) - current = fmap (Lexical, ) . pure . pure $ currentScope' - edges = Map.fromList (superclassEdges <> current) - childScope <- newPreludeScope edges - putDeclarationScope declaration childScope - - withScope childScope $ do - void body - - unit - -defineNamespace :: ( AbstractValue term address value m - , HasCallStack - , Has (Allocator address) sig m - , Has (Deref value) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has Fresh sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Ord address - ) - => Declaration - -> Evaluator term address value m a - -> Evaluator term address value m () -defineNamespace declaration@Declaration{..} body = void . define declaration Default Public $ do - withChildFrame declaration $ \frame -> do - _ <- body - namespace unDeclaration frame diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs deleted file mode 100644 index 8aa201a379..0000000000 --- a/src/Control/Abstract/PythonPackage.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UndecidableInstances #-} -module Control.Abstract.PythonPackage -( runPythonPackaging, Strategy(..) ) where - -import Analysis.Name (name) -import Control.Abstract as Abstract -import Control.Algebra -import Control.Effect.Sum.Project -import Control.Monad -import Data.Abstract.Path (stripQuotes) -import Data.Abstract.Value.Concrete (Value (..)) -import qualified Data.Map as Map -import Data.Semilattice.Lower -import Data.Text (Text) - -data Strategy = Unknown | Packages [Text] | FindPackages [Text] - deriving (Show, Eq) - -runPythonPackaging :: Evaluator term address (Value term address) (PythonPackagingC term address m) a - -> Evaluator term address (Value term address) m a -runPythonPackaging = raiseHandler runPythonPackagingC - - -newtype PythonPackagingC term address m a = PythonPackagingC { runPythonPackagingC :: m a } - deriving (Applicative, Functor, Monad) - -wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address m a -wrap = PythonPackagingC . runEvaluator - -instance ( Algebra sig m - , Project (Function term address (Value term address)) sig - , Has (Function term address (Value term address)) sig m - , Has (State Strategy) sig m - , Has (Abstract.String (Value term address)) sig m - , Has (Abstract.Array (Value term address)) sig m - ) - => Algebra sig (PythonPackagingC term address m) where - alg op - | Just e <- prj op = wrap $ case handleCoercible e of - Call callName params k -> Evaluator . k =<< do - case callName of - Closure _ _ name' _ paramNames _ _ _ -> do - let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params) - let asStrings = asArray >=> traverse asString - - if Just (name "find_packages") == name' then do - as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings) - put (FindPackages as) - else if Just (name "setup") == name' then do - packageState <- get - if packageState == Control.Abstract.PythonPackage.Unknown then do - as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings) - put (Packages as) - else - pure () - else pure () - _ -> pure () - call callName params - Function name params body scope k -> function name params body scope >>= Evaluator . k - BuiltIn n b k -> builtIn n b >>= Evaluator . k - Bind obj value k -> bindThis obj value >>= Evaluator . k - | otherwise = PythonPackagingC . alg $ handleCoercible op diff --git a/src/Control/Abstract/Roots.hs b/src/Control/Abstract/Roots.hs deleted file mode 100644 index 5f219a027c..0000000000 --- a/src/Control/Abstract/Roots.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} -module Control.Abstract.Roots -( ValueRoots(..) -, Live -, askRoots -, extraRoots -) where - -import Control.Abstract.Evaluator -import Data.Abstract.Live - --- | Value types, e.g. closures, which can root a set of addresses. -class ValueRoots address value where - -- | Compute the set of addresses rooted by a given value. - valueRoots :: value -> Live address - --- | Retrieve the local 'Live' set. -askRoots :: Has (Reader (Live address)) sig m => Evaluator term address value m (Live address) -askRoots = ask - --- | Run a computation with the given 'Live' set added to the local root set. -extraRoots :: (Has (Reader (Live address)) sig m, Ord address) => Live address -> Evaluator term address value m a -> Evaluator term address value m a -extraRoots roots = local (<> roots) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs deleted file mode 100644 index 564b48bc31..0000000000 --- a/src/Control/Abstract/ScopeGraph.hs +++ /dev/null @@ -1,394 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Control.Abstract.ScopeGraph - ( lookup - , declare - , declareMaybeName - , reference - , newScope - , newPreludeScope - , Declaration(..) - , ScopeGraph - , ScopeError(..) - , Reference(..) - , Relation(..) - , EdgeLabel(..) - , CurrentScope(..) - , Info(..) - , AccessControl(..) - , currentScope - , insertExportEdge - , insertImportEdge - , insertLexicalEdge - , withScope - , associatedScope - , declarationByName - , declarationsByAccessControl - , declarationsByRelation - , putDeclarationScope - , putDeclarationSpan - , insertImportReference - , lookupScopePath - , maybeLookupScopePath - , lookupDeclarationScope - , lookupScope - , Allocator(..) - , AllocatorC(..) - , runAllocator - , alloc - , Slot(..) - , runScopeErrorWith - , runScopeError - , throwScopeError - , Scope - , ScopeGraph.Path - ) where - -import Analysis.Name hiding (name) -import Control.Abstract.Evaluator hiding (Local) -import Control.Algebra -import qualified Control.Carrier.Resumable.Either as Either -import qualified Control.Carrier.Resumable.Resume as With -import Data.Abstract.BaseError -import Data.Abstract.Module -import Data.Abstract.ScopeGraph - ( AccessControl (..) - , Declaration (..) - , EdgeLabel - , Info (..) - , Kind - , Reference - , Relation (..) - , Scope (..) - , ScopeGraph - , Slot (..) - ) -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Functor.Classes -import Data.Map (Map) -import Data.Maybe.Exts -import GHC.Generics (Generic1) -import Prelude hiding (lookup) -import Scope.Types (CurrentScope (..)) -import Source.Span - -lookup :: ( Ord address - , Has (State (ScopeGraph address)) sig m - ) - => Reference - -> Evaluator term address value m (Maybe address) -lookup ref = ScopeGraph.scopeOfRef ref <$> get - -declare :: ( Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Ord address - ) - => Declaration - -> Relation - -> AccessControl - -> Span - -> Kind - -> Maybe address - -> Evaluator term address value m () -declare decl rel accessControl span kind scope = do - currentAddress <- currentScope - moduleInfo <- ask @ModuleInfo - modify (fst . ScopeGraph.declare decl moduleInfo rel accessControl span kind scope currentAddress) - --- | If the provided name is 'Nothing' we want to reflect that the declaration's name was a generated name (gensym). --- We use the 'Gensym' relation to indicate that. Otherwise, we use the provided 'relation'. -declareMaybeName :: ( Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has Fresh sig m - , Ord address - ) - => Maybe Name - -> Relation - -> AccessControl - -> Span - -> Kind - -> Maybe address - -> Evaluator term address value m Name -declareMaybeName maybeName relation ac span kind scope = do - case maybeName of - Just name -> declare (Declaration name) relation ac span kind scope >> pure name - _ -> gensym >>= \name -> declare (Declaration name) Gensym ac span kind scope >> pure name - -putDeclarationScope :: ( Ord address - , Has (Reader (CurrentScope address)) sig m - , Has (State (ScopeGraph address)) sig m - ) - => Declaration - -> address - -> Evaluator term address value m () -putDeclarationScope decl assocScope = do - currentAddress <- currentScope - modify (ScopeGraph.insertDeclarationScope decl assocScope currentAddress) - -putDeclarationSpan :: forall address sig m term value . - ( Ord address - , Has (State (ScopeGraph address)) sig m - ) - => Declaration - -> Span - -> Evaluator term address value m () -putDeclarationSpan decl = modify @(ScopeGraph address) . ScopeGraph.insertDeclarationSpan decl - -reference :: forall address sig m term value . - ( Ord address - , Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - ) - => Reference - -> Span - -> Kind - -> Declaration - -> Evaluator term address value m () -reference ref span kind decl = do - currentAddress <- currentScope - moduleInfo <- ask @ModuleInfo - modify @(ScopeGraph address) (ScopeGraph.reference ref moduleInfo span kind decl currentAddress) - --- | Combinator to insert an export edge from the current scope to the provided scope address. -insertExportEdge :: (Has (Reader (CurrentScope scopeAddress)) sig m, Has (State (ScopeGraph scopeAddress)) sig m, Ord scopeAddress) - => scopeAddress - -> Evaluator term scopeAddress value m () -insertExportEdge = insertEdge ScopeGraph.Export - --- | Combinator to insert an import edge from the current scope to the provided scope address. -insertImportEdge :: (Has (Reader (CurrentScope scopeAddress)) sig m, Has (State (ScopeGraph scopeAddress)) sig m, Ord scopeAddress) - => scopeAddress - -> Evaluator term scopeAddress value m () -insertImportEdge = insertEdge ScopeGraph.Import - --- | Combinator to insert a lexical edge from the current scope to the provided scope address. -insertLexicalEdge :: (Has (Reader (CurrentScope scopeAddress)) sig m, Has (State (ScopeGraph scopeAddress)) sig m, Ord scopeAddress) - => scopeAddress - -> Evaluator term scopeAddress value m () -insertLexicalEdge = insertEdge ScopeGraph.Lexical - -insertEdge :: ( Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Ord address) - => EdgeLabel - -> address - -> Evaluator term address value m () -insertEdge label target = do - currentAddress <- currentScope - modify (ScopeGraph.insertEdge label target currentAddress) - --- | Inserts a new scope into the scope graph with the given edges. -newScope :: ( Has (Allocator address) sig m - , Has (State (ScopeGraph address)) sig m - , Has Fresh sig m - , Ord address - ) - => Map EdgeLabel [address] - -> Evaluator term address value m address -newScope edges = do - -- Take the edges and construct a new scope - name <- gensym - address <- alloc name - address <$ modify (ScopeGraph.newScope address edges) - --- | Inserts a new scope into the scope graph with the given edges. -newPreludeScope :: ( Has (Allocator address) sig m - , Has (State (ScopeGraph address)) sig m - , Has Fresh sig m - , Ord address - ) - => Map EdgeLabel [address] - -> Evaluator term address value m address -newPreludeScope edges = do - -- Take the edges and construct a new scope - name <- gensym - address <- alloc name - address <$ modify (ScopeGraph.newPreludeScope address edges) - -currentScope :: Has (Reader (CurrentScope address)) sig m - => Evaluator term address value m address -currentScope = asks unCurrentScope - -lookupScope :: ( Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State (ScopeGraph address)) sig m - , Ord address - ) - => address - -> Evaluator term address value m (Scope address) -lookupScope address = maybeM (throwScopeError LookupScopeError) . ScopeGraph.lookupScope address =<< get - -declarationsByRelation :: ( Has (State (ScopeGraph address)) sig m - , Ord address - ) - => address - -> Relation - -> Evaluator term address value m [ Info address ] -declarationsByRelation scope relation = ScopeGraph.declarationsByRelation scope relation <$> get - -declarationByName :: ( Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State (ScopeGraph address)) sig m - , Ord address - ) - => address - -> Declaration - -> Evaluator term address value m (Info address) -declarationByName scope name = do - scopeGraph <- get - maybeM (throwScopeError $ DeclarationByNameError name) (ScopeGraph.declarationByName scope name scopeGraph) - -declarationsByAccessControl :: ( Has (State (ScopeGraph address)) sig m - , Ord address - ) - => address - -> AccessControl - -> Evaluator term address value m [ Info address ] -declarationsByAccessControl scopeAddress accessControl = ScopeGraph.declarationsByAccessControl scopeAddress accessControl <$> get - -insertImportReference :: ( Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Ord address - ) - => Reference - -> Span - -> Kind - -> Declaration - -> address - -> Evaluator term address value m () -insertImportReference ref span kind decl scopeAddress = do - scopeGraph <- get - scope <- lookupScope scopeAddress - currentAddress <- currentScope - moduleInfo <- ask @ModuleInfo - newScope <- maybeM (throwScopeError ImportReferenceError) (ScopeGraph.insertImportReference ref moduleInfo span kind decl currentAddress scopeGraph scope) - insertScope scopeAddress newScope - -insertScope :: ( Has (State (ScopeGraph address)) sig m - , Ord address - ) - => address - -> Scope address - -> Evaluator term address value m () -insertScope scopeAddress scope = modify (ScopeGraph.insertScope scopeAddress scope) - -maybeLookupScopePath :: ( Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Ord address - ) - => Declaration - -> Evaluator term address value m (Maybe (ScopeGraph.Path address)) -maybeLookupScopePath Declaration{..} = do - currentAddress <- currentScope - gets (ScopeGraph.lookupScopePath unDeclaration currentAddress) - -lookupScopePath :: ( Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Ord address - ) - => Declaration - -> Evaluator term address value m (ScopeGraph.Path address) -lookupScopePath decl@Declaration{..} = do - currentAddress <- currentScope - scopeGraph <- get - maybeM (throwScopeError $ LookupPathError decl) (ScopeGraph.lookupScopePath unDeclaration currentAddress scopeGraph) - -lookupDeclarationScope :: ( Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Ord address - ) - => Declaration - -> Evaluator term address value m address -lookupDeclarationScope decl = do - path <- lookupScopePath decl - currentScope' <- currentScope - maybeM (throwScopeError $ LookupDeclarationScopeError decl) (ScopeGraph.pathDeclarationScope currentScope' path) - -associatedScope :: (Ord address, Has (State (ScopeGraph address)) sig m) => Declaration -> Evaluator term address value m (Maybe address) -associatedScope decl = ScopeGraph.associatedScope decl <$> get - -withScope :: Has (Reader (CurrentScope address)) sig m - => address - -> Evaluator term address value m a - -> Evaluator term address value m a -withScope scope = local (const (CurrentScope scope)) - -throwScopeError :: ( Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - ) - => ScopeError address resume - -> Evaluator term address value m resume -throwScopeError = throwBaseError - -data ScopeError address return where - ScopeError :: Declaration -> Span -> ScopeError address (Slot address) - LookupScopeError :: ScopeError address (Scope address) - ImportReferenceError :: ScopeError address (Scope address) - LookupPathError :: Declaration -> ScopeError address (ScopeGraph.Path address) - LookupDeclarationScopeError :: Declaration -> ScopeError address address - DeclarationByNameError :: Declaration -> ScopeError address (Info address) - CurrentScopeError :: ScopeError address address - -deriving instance Eq (ScopeError address return) -deriving instance Show (ScopeError address return) -instance Show address => Show1 (ScopeError address) where liftShowsPrec _ _ = showsPrec -instance Eq1 (ScopeError address) where - liftEq _ (ScopeError m1 n1) (ScopeError m2 n2) = m1 == m2 && n1 == n2 - liftEq _ LookupScopeError LookupScopeError = True - liftEq _ ImportReferenceError ImportReferenceError = True - liftEq _ (LookupPathError decl1) (LookupPathError decl2) = decl1 == decl2 - liftEq _ (LookupDeclarationScopeError decl1) (LookupDeclarationScopeError decl2) = decl1 == decl2 - liftEq _ CurrentScopeError CurrentScopeError = True - liftEq _ _ _ = False - -alloc :: (Has (Allocator address) sig m) => Name -> Evaluator term address value m address -alloc = send . flip Alloc pure - -data Allocator address (m :: * -> *) k - = Alloc Name (address -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Allocator address) -instance Effect (Allocator address) - -runAllocator :: Evaluator term address value (AllocatorC address m) a - -> Evaluator term address value m a -runAllocator = raiseHandler runAllocatorC - -newtype AllocatorC address m a = AllocatorC { runAllocatorC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - -runScopeErrorWith :: (forall resume . BaseError (ScopeError address) resume -> Evaluator term address value m resume) - -> Evaluator term address value (With.ResumableC (BaseError (ScopeError address)) m) a - -> Evaluator term address value m a -runScopeErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) - -runScopeError :: Evaluator term address value (Either.ResumableC (BaseError (ScopeError address)) m) a - -> Evaluator term address value m (Either (Either.SomeError (BaseError (ScopeError address))) a) -runScopeError = raiseHandler Either.runResumable diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs deleted file mode 100644 index c51ba754a6..0000000000 --- a/src/Control/Abstract/Value.hs +++ /dev/null @@ -1,479 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -module Control.Abstract.Value -( AbstractValue(..) -, AbstractIntro(..) -, Comparator(..) --- * Domain effects --- $domainEffects -, function -, BuiltIn(..) -, bindThis -, builtIn -, call -, Function(..) -, runFunction -, FunctionC(..) -, boolean -, asBool -, ifthenelse -, Boolean(..) -, runBoolean -, BooleanC(..) -, while -, doWhile -, forLoop -, While(..) -, runWhile -, WhileC(..) -, unit -, Unit(..) -, runUnit -, UnitC(..) -, string -, asString -, String(..) -, StringC(..) -, runString -, integer -, float -, rational -, liftNumeric -, liftNumeric2 -, Numeric(..) -, NumericC(..) -, object -, scopedEnvironment -, klass -, Object(..) -, ObjectC(..) -, runObject -, runNumeric -, runNumericFunction -, runNumeric2Function -, castToInteger -, runBitwiseFunction -, runBitwise2Function -, liftBitwise -, liftBitwise2 -, unsignedRShift -, Bitwise(..) -, BitwiseC(..) -, runBitwise -, array -, asArray -, Array(..) -, ArrayC(..) -, runArray -, hash -, kvPair -, Hash(..) -, runHash -, HashC(..) -) where - -import Analysis.Name -import Control.Abstract.Evaluator -import Control.Abstract.Heap -import Control.Abstract.ScopeGraph (CurrentScope, Declaration, ScopeGraph) -import Control.Algebra -import Control.Carrier.Reader -import Data.Abstract.BaseError -import Data.Abstract.Module -import Data.Abstract.Number (Number, SomeNumber) -import Data.Bits -import Data.Scientific (Scientific) -import Data.Text (Text) -import GHC.Generics (Generic, Generic1) -import Prelude hiding (String) -import Source.Span - --- | This datum is passed into liftComparison to handle the fact that Ruby and PHP --- have built-in generalized-comparison ("spaceship") operators. If you want to --- encapsulate a traditional, boolean-returning operator, wrap it in 'Concrete'; --- if you want the generalized comparator, pass in 'Generalized'. In 'AbstractValue' --- instances, you can then then handle the different cases to return different --- types, if that's what you need. -data Comparator - = Concrete (forall a . Ord a => a -> a -> Bool) - | Generalized - --- Domain effects - --- $domainEffects --- Value effects are effects modelling the /introduction/ & /elimination/ of some specific kind of value. --- --- Modelling each of these as effects has several advantages∷ --- --- * It is strictly more flexible than modelling them as methods in a typeclass, as effect list–indexed typeclasses must be constrained at every list of effects at which they can be applied, whereas effect membership constraints can be deduced recursively (i.e. if @X@ is constrained to be a member of @effects@, it is automatically deducible that it is also a member of @Y \': effects@). --- * It offers us the potential of specializing the handlers on a language-by-language basis without the need for extra type parameters (albeit at the cost of automatic selection). --- * It offers us the potential of fine-grained specialization of the abstract domain, enabling convenient, piecemeal customization of the domain, and even semi-abstract domains. --- * Finally, it should eventually allow us to customize _which_ value effects are available for a given language; e.g. a language without OO features would not require OO value effects. (This would also rely on 'Evaluatable' instances being able to specify membership constraints, which is not currently possible.) --- --- In the concrete domain, introductions & eliminations respectively construct & pattern match against values, while in abstract domains they respectively construct & project finite sets of discrete observations of abstract values. For example, an abstract domain modelling integers as a sign (-, 0, or +) would introduce abstract values by mapping integers to their sign and eliminate them by mapping signs back to some canonical integer, e.g. - -> -1, 0 -> 0, + -> 1. - -function :: Has (Function term address value) sig m => Name -> [Name] -> term -> address -> Evaluator term address value m value -function name params body scope = sendFunction (Function name params body scope pure) - -data BuiltIn - = Print - | Show - deriving (Eq, Ord, Show, Generic) - -builtIn :: Has (Function term address value) sig m => address -> BuiltIn -> Evaluator term address value m value -builtIn address = sendFunction . flip (BuiltIn address) pure - -call :: Has (Function term address value) sig m => value -> [value] -> Evaluator term address value m value -call fn args = sendFunction (Call fn args pure) - -sendFunction :: Has (Function term address value) sig m => Function term address value (Evaluator term address value m) a -> Evaluator term address value m a -sendFunction = send - -bindThis :: Has (Function term address value) sig m => value -> value -> Evaluator term address value m value -bindThis this that = sendFunction (Bind this that pure) - -data Function term address value (m :: * -> *) k - = Function Name [Name] term address (value -> m k) -- ^ A function is parameterized by its name, parameter names, body, parent scope, and returns a ValueRef. - | BuiltIn address BuiltIn (value -> m k) -- ^ A built-in is parameterized by its parent scope, BuiltIn type, and returns a value. - | Call value [value] (value -> m k) -- ^ A Call takes a set of values as parameters and returns a ValueRef. - | Bind value value (value -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Function term address value) -instance Effect (Function term address value) - -runFunction :: (term -> Evaluator term address value (FunctionC term address value m) value) - -> Evaluator term address value (FunctionC term address value m) a - -> Evaluator term address value m a -runFunction eval = raiseHandler (runReader (runEvaluator . eval) . runFunctionC) - -newtype FunctionC term address value m a = FunctionC { runFunctionC :: ReaderC (term -> FunctionC term address value m value) m a } - deriving (Alternative, Applicative, Functor, Monad) - --- | Construct a boolean value in the abstract domain. -boolean :: Has (Boolean value) sig m => Bool -> m value -boolean = send . flip Boolean pure - --- | Extract a 'Bool' from a given value. -asBool :: Has (Boolean value) sig m => value -> m Bool -asBool = send . flip AsBool pure - --- | Eliminate boolean values. TODO: s/boolean/truthy -ifthenelse :: Has (Boolean value) sig m => value -> m a -> m a -> m a -ifthenelse v t e = asBool v >>= \ c -> if c then t else e - -data Boolean value (m :: * -> *) k - = Boolean Bool (value -> m k) - | AsBool value (Bool -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Boolean value) -instance Effect (Boolean value) - -runBoolean :: Evaluator term address value (BooleanC value m) a - -> Evaluator term address value m a -runBoolean = raiseHandler runBooleanC - -newtype BooleanC value m a = BooleanC { runBooleanC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - - --- | The fundamental looping primitive, built on top of 'ifthenelse'. -while :: Has (While value) sig m - => Evaluator term address value m value -- ^ Condition - -> Evaluator term address value m value -- ^ Body - -> Evaluator term address value m value -while cond body = send (While cond body pure) - --- | Do-while loop, built on top of while. -doWhile :: Has (While value) sig m - => Evaluator term address value m value -- ^ Body - -> Evaluator term address value m value -- ^ Condition - -> Evaluator term address value m value -doWhile body cond = body *> while cond body - --- | C-style for loops. -forLoop :: ( Has (Allocator address) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (While value) sig m - , Has Fresh sig m - , Ord address - ) - => Evaluator term address value m value -- ^ Initial statement - -> Evaluator term address value m value -- ^ Condition - -> Evaluator term address value m value -- ^ Increment/stepper - -> Evaluator term address value m value -- ^ Body - -> Evaluator term address value m value -forLoop initial cond step body = initial *> while cond (withLexicalScopeAndFrame body *> step) - -data While value m k - = While (m value) (m value) (value -> m k) - deriving (Functor, Generic1) - -instance HFunctor (While value) where - hmap f (While cond body k) = While (f cond) (f body) (f . k) - -runWhile :: Evaluator term address value (WhileC value m) a - -> Evaluator term address value m a -runWhile = raiseHandler runWhileC - -newtype WhileC value m a = WhileC { runWhileC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - --- | Construct an abstract unit value. -unit :: Has (Unit value) sig m => Evaluator term address value m value -unit = send (Unit pure) - -newtype Unit value (m :: * -> *) k - = Unit (value -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Unit value) -instance Effect (Unit value) - -runUnit :: Evaluator term address value (UnitC value m) a - -> Evaluator term address value m a -runUnit = raiseHandler runUnitC - -newtype UnitC value m a = UnitC { runUnitC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - --- | Construct a String value in the abstract domain. -string :: Has (String value) sig m => Text -> m value -string t = send (String t pure) - --- | Extract 'Text' from a given value. -asString :: Has (String value) sig m => value -> m Text -asString v = send (AsString v pure) - -data String value (m :: * -> *) k - = String Text (value -> m k) - | AsString value (Text -> m k) - deriving (Functor, Generic1) - -instance HFunctor (String value) -instance Effect (String value) - -newtype StringC value m a = StringC { runStringC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - -runString :: Evaluator term address value (StringC value m) a - -> Evaluator term address value m a -runString = raiseHandler runStringC - - --- | Construct an abstract integral value. -integer :: Has (Numeric value) sig m => Integer -> m value -integer t = send (Integer t pure) - --- | Construct a floating-point value. -float :: Has (Numeric value) sig m => Scientific -> m value -float t = send (Float t pure) - --- | Construct a rational value. -rational :: Has (Numeric value) sig m => Rational -> m value -rational t = send (Rational t pure) - --- | Lift a unary operator over a 'Num' to a function on 'value's. -liftNumeric :: Has (Numeric value) sig m - => (forall a . Num a => a -> a) - -> value - -> m value -liftNumeric t v = send (LiftNumeric (NumericFunction t) v pure) - --- | Lift a pair of binary operators to a function on 'value's. --- You usually pass the same operator as both arguments, except in the cases where --- Haskell provides different functions for integral and fractional operations, such --- as division, exponentiation, and modulus. -liftNumeric2 :: Has (Numeric value) sig m - => (forall a b. Number a -> Number b -> SomeNumber) - -> value - -> value - -> m value -liftNumeric2 t v1 v2 = send (LiftNumeric2 (Numeric2Function t) v1 v2 pure) - -newtype NumericFunction = NumericFunction { runNumericFunction :: forall a . Num a => a -> a } - -newtype Numeric2Function = Numeric2Function { runNumeric2Function :: forall a b. Number a -> Number b -> SomeNumber } - -data Numeric value (m :: * -> *) k - = Integer Integer (value -> m k) - | Float Scientific (value -> m k) - | Rational Rational (value -> m k) - | LiftNumeric NumericFunction value (value -> m k) - | LiftNumeric2 Numeric2Function value value (value -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Numeric value) -instance Effect (Numeric value) - -newtype NumericC value m a = NumericC { runNumericC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - -runNumeric :: Evaluator term address value (NumericC value m) a - -> Evaluator term address value m a -runNumeric = raiseHandler runNumericC - - --- | Cast numbers to integers -castToInteger :: Has (Bitwise value) sig m => value -> m value -castToInteger t = send (CastToInteger t pure) - --- | Lift a unary bitwise operator to values. This is usually 'complement'. -liftBitwise :: Has (Bitwise value) sig m - => (forall a . Bits a => a -> a) - -> value - -> m value -liftBitwise t v = send (LiftBitwise (BitwiseFunction t) v pure) - --- | Lift a binary bitwise operator to values. The Integral constraint is --- necessary to satisfy implementation details of Haskell left/right shift, --- but it's fine, since these are only ever operating on integral values. -liftBitwise2 :: Has (Bitwise value) sig m - => (forall a . (Integral a, Bits a) => a -> a -> a) - -> value - -> value - -> m value -liftBitwise2 t v1 v2 = send (LiftBitwise2 (Bitwise2Function t) v1 v2 pure) - -unsignedRShift :: Has (Bitwise value) sig m - => value - -> value - -> m value -unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 pure) - -newtype BitwiseFunction = BitwiseFunction { runBitwiseFunction :: forall a . Bits a => a -> a } - -newtype Bitwise2Function = Bitwise2Function { runBitwise2Function :: forall a . (Integral a, Bits a) => a -> a -> a } - -data Bitwise value (m :: * -> *) k - = CastToInteger value (value -> m k) - | LiftBitwise BitwiseFunction value (value -> m k) - | LiftBitwise2 Bitwise2Function value value (value -> m k) - | UnsignedRShift value value (value -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Bitwise value) -instance Effect (Bitwise value) - -runBitwise :: Evaluator term address value (BitwiseC value m) a - -> Evaluator term address value m a -runBitwise = raiseHandler runBitwiseC - -newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - -object :: Has (Object address value) sig m => address -> m value -object address = send (Object address pure) - --- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). -scopedEnvironment :: Has (Object address value) sig m => value -> m (Maybe address) -scopedEnvironment value = send (ScopedEnvironment value pure) - --- | Build a class value from a name and environment. --- declaration is the new class's identifier --- address is the environment to capture -klass :: Has (Object address value) sig m => Declaration -> address -> m value -klass d a = send (Klass d a pure) - -data Object address value m k - = Object address (value -> m k) - | ScopedEnvironment value (Maybe address -> m k) - | Klass Declaration address (value -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Object address value) -instance Effect (Object address value) - -newtype ObjectC address value m a = ObjectC { runObjectC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - -runObject :: Evaluator term address value (ObjectC address value m) a - -> Evaluator term address value m a -runObject = raiseHandler runObjectC - --- | Construct an array of zero or more values. -array :: Has (Array value) sig m => [value] -> m value -array v = send (Array v pure) - -asArray :: Has (Array value) sig m => value -> m [value] -asArray v = send (AsArray v pure) - -data Array value (m :: * -> *) k - = Array [value] (value -> m k) - | AsArray value ([value] -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Array value) -instance Effect (Array value) - -newtype ArrayC value m a = ArrayC { runArrayC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - -runArray :: Evaluator term address value (ArrayC value m) a - -> Evaluator term address value m a -runArray = raiseHandler runArrayC - --- | Construct a hash out of pairs. -hash :: Has (Hash value) sig m => [(value, value)] -> m value -hash v = send (Hash v pure) - --- | Construct a key-value pair for use in a hash. -kvPair :: Has (Hash value) sig m => value -> value -> m value -kvPair v1 v2 = send (KvPair v1 v2 pure) - -data Hash value (m :: * -> *) k - = Hash [(value, value)] (value -> m k) - | KvPair value value (value -> m k) - deriving (Functor, Generic1) - -instance HFunctor (Hash value) -instance Effect (Hash value) - -newtype HashC value m a = HashC { runHashC :: m a } - deriving (Alternative, Applicative, Functor, Monad) - -runHash :: Evaluator term address value (HashC value m) a - -> Evaluator term address value m a -runHash = raiseHandler runHashC - -class Show value => AbstractIntro value where - -- | Construct the nil/null datatype. - null :: value - --- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). --- --- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class AbstractIntro value => AbstractValue term address value carrier where - -- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values. - liftComparison :: Comparator -> (value -> value -> Evaluator term address value carrier value) - - -- | Construct an N-ary tuple of multiple (possibly-disjoint) values - tuple :: [value] -> Evaluator term address value carrier value - - -- | Extract the contents of a key-value pair as a tuple. - asPair :: value -> Evaluator term address value carrier (value, value) - - -- | @index x i@ computes @x[i]@, with zero-indexing. - index :: value -> value -> Evaluator term address value carrier value - - -- | Build a namespace value from a name and environment stack - -- - -- Namespaces model closures with monoidal environments. - namespace :: Name -- ^ The namespace's identifier - -> address -- ^ The frame of the namespace. - -> Evaluator term address value carrier value diff --git a/src/Control/Carrier/Parse/Measured.hs b/src/Control/Carrier/Parse/Measured.hs index f5a5212d02..22f4416c8f 100644 --- a/src/Control/Carrier/Parse/Measured.hs +++ b/src/Control/Carrier/Parse/Measured.hs @@ -11,33 +11,27 @@ module Control.Carrier.Parse.Measured ( -- * Parse carrier ParseC(..) -- * Exceptions -, AssignmentTimedOut(..) +, ParsingTimedOut(..) -- * Parse effect , module Control.Effect.Parse ) where -import qualified Assigning.Assignment as Assignment import Control.Algebra import Control.Effect.Error import Control.Effect.Lift import Control.Effect.Parse import Control.Effect.Reader -import Control.Effect.Timeout import Control.Effect.Trace import Control.Exception import Control.Monad import Control.Monad.IO.Class import Data.Blob -import qualified Data.Error as Error import qualified Data.Flag as Flag -import Data.Foldable -import qualified Data.Syntax as Syntax import Parsing.Parser import Parsing.TreeSitter import Semantic.Config import Semantic.Task (TaskSession (..)) import Semantic.Telemetry -import Source.Source (Source) newtype ParseC m a = ParseC { runParse :: m a } deriving (Applicative, Functor, Monad, MonadFail, MonadIO) @@ -58,7 +52,6 @@ runParser :: ( Has (Error SomeException) sig m , Has (Reader TaskSession) sig m , Has Telemetry sig m - , Has (Lift IO) sig m , Has Trace sig m , MonadIO m ) @@ -80,88 +73,13 @@ runParser blob@Blob{..} parser = case parser of writeLog Error "precise parsing failed" (("task", "parse") : ("exception", "\"" <> displayException e <> "\"") : languageTag) throwError (SomeException e)) - AssignmentParser parser assignment -> runAssignment Assignment.assign parser blob assignment - where languageTag = [("language" :: String, show (blobLanguage blob))] executeParserAction act = do -- Test harnesses can specify that parsing must fail, for testing purposes. shouldFailFlag <- asks (Flag.toBool FailTestParsing . configFailParsingForTesting . config) - when shouldFailFlag (throwError (SomeException AssignmentTimedOut)) + when shouldFailFlag (throwError (SomeException ParsingTimedOut)) act >>= either (\e -> trace (displayException e) *> throwError (SomeException e)) pure -data AssignmentTimedOut = AssignmentTimedOut deriving (Show) - -instance Exception AssignmentTimedOut - - - -runAssignment - :: ( Foldable term - , Syntax.HasErrors term - , Has (Error SomeException) sig m - , Has (Reader TaskSession) sig m - , Has Telemetry sig m - , Has Trace sig m - , Has (Lift IO) sig m - , MonadIO m - ) - => (Source -> assignment (term Assignment.Loc) -> ast -> Either (Error.Error String) (term Assignment.Loc)) - -> Parser ast - -> Blob - -> assignment (term Assignment.Loc) - -> m (term Assignment.Loc) -runAssignment assign parser blob@Blob{..} assignment = do - taskSession <- ask - let requestID' = ("github_request_id", requestID taskSession) - let isPublic' = ("github_is_public", show (isPublic taskSession)) - let logPrintFlag = configLogPrintSource . config $ taskSession - let blobFields = ("path", if isPublic taskSession || Flag.toBool LogPrintSource logPrintFlag then blobFilePath blob else "") - let logFields = requestID' : isPublic' : blobFields : languageTag - let shouldFailForTesting = configFailParsingForTesting $ config taskSession - let shouldFailOnParsing = optionsFailOnParseError . configOptions $ config taskSession - let shouldFailOnWarning = optionsFailOnWarning . configOptions $ config taskSession - - ast <- runParser blob parser `catchError` \ (SomeException err) -> do - writeStat (increment "parse.parse_failures" languageTag) - writeLog Error "failed parsing" (("task", "parse") : logFields) - throwError (toException err) - - res <- timeout (configAssignmentTimeout (config taskSession)) . time "parse.assign" languageTag $ - case assign blobSource assignment ast of - Left err -> do - writeStat (increment "parse.assign_errors" languageTag) - logError taskSession Error blob err (("task", "assign") : logFields) - throwError (toException err) - Right term -> do - for_ (zip (Syntax.getErrors term) [(0::Integer)..]) $ \ (err, i) -> case Error.errorActual err of - Just "ParseError" -> do - when (i == 0) $ writeStat (increment "parse.parse_errors" languageTag) - logError taskSession Warning blob err (("task", "parse") : logFields) - when (Flag.toBool FailOnParseError shouldFailOnParsing) (throwError (toException err)) - _ -> do - when (i == 0) $ writeStat (increment "parse.assign_warnings" languageTag) - logError taskSession Warning blob err (("task", "assign") : logFields) - when (Flag.toBool FailOnWarning shouldFailOnWarning) (throwError (toException err)) - term <$ writeStat (count "parse.nodes" (length term) languageTag) - case res of - Just r | not (Flag.toBool FailTestParsing shouldFailForTesting) -> pure r - _ -> do - writeStat (increment "assign.assign_timeouts" languageTag) - writeLog Error "assignment timeout" (("task", "assign") : logFields) - throwError (SomeException AssignmentTimedOut) - where languageTag = [("language", show (blobLanguage blob))] - - --- | Log an 'Error.Error' at the specified 'Level'. -logError :: Has Telemetry sig m - => TaskSession - -> Level - -> Blob - -> Error.Error String - -> [(String, String)] - -> m () -logError TaskSession{..} level blob err = - let shouldLogSource = configLogPrintSource config - shouldColorize = Flag.switch IsTerminal Error.Colourize $ configIsTerminal config - in writeLog level (Error.formatError shouldLogSource shouldColorize blob err) +data ParsingTimedOut = ParsingTimedOut deriving (Eq, Show) +instance Exception ParsingTimedOut diff --git a/src/Control/Carrier/Parse/Simple.hs b/src/Control/Carrier/Parse/Simple.hs index 2763d6c9a9..5f7bc6e962 100644 --- a/src/Control/Carrier/Parse/Simple.hs +++ b/src/Control/Carrier/Parse/Simple.hs @@ -17,7 +17,6 @@ module Control.Carrier.Parse.Simple , module Control.Effect.Parse ) where -import qualified Assigning.Assignment as Assignment import Control.Algebra import Control.Carrier.Reader import Control.Effect.Error @@ -59,9 +58,6 @@ runParser timeout blob@Blob{..} parser = case parser of parseToPreciseAST timeout timeout language blob >>= either (throwError . SomeException) pure - AssignmentParser parser assignment -> - runParser timeout blob parser >>= either (throwError . toException) pure . Assignment.assign blobSource assignment - newtype ParseFailure = ParseFailure String deriving (Show) diff --git a/src/Data/Abstract/AccessControls/Class.hs b/src/Data/Abstract/AccessControls/Class.hs deleted file mode 100644 index d7dd1ca800..0000000000 --- a/src/Data/Abstract/AccessControls/Class.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Data.Abstract.AccessControls.Class - ( AccessControls (..) - , AccessControls1 (..) - ) where - -import Data.Abstract.ScopeGraph (AccessControl(..)) - -{-| - The 'AccessControls' typeclass provides a mapping between a syntax and its associated 'AccessControl' type (i.e. public, protected, or private). - - Because not every syntax relates to the idea of access control, the 'termToAccessControl' method defaults to returning a 'Nothing' as the default for all syntax. - - Specialized instances should be defined per syntax when considering its 'AccessControl' is necessary for its evaluation. --} -class AccessControls syntax where - termToAccessControl :: syntax -> Maybe AccessControl - termToAccessControl = const Nothing - -{-| - The 'AccessControls1' typeclass allows lifting of a function mapping a syntax to its 'AccessControl' type for rank 1 types. - - As described in the notes for the 'AccessControls' typeclass, the default for the 'liftTermToAccessControl' method is 'Nothing' for syntax terms whose evaluation does not require consideration of access control. --} -class AccessControls1 syntax where - liftTermToAccessControl :: (a -> Maybe AccessControl) -> syntax a -> Maybe AccessControl - liftTermToAccessControl _ _ = Nothing diff --git a/src/Data/Abstract/AccessControls/Instances.hs b/src/Data/Abstract/AccessControls/Instances.hs deleted file mode 100644 index bd405fd081..0000000000 --- a/src/Data/Abstract/AccessControls/Instances.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeApplications, UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} -module Data.Abstract.AccessControls.Instances () where - -import Data.Sum -import Data.Term -import Data.Abstract.AccessControls.Class - -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Directive as Directive -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import qualified Language.Go.Syntax as Go -import qualified Language.Go.Term as Go -import qualified Language.Go.Type as Go -import qualified Language.PHP.Syntax as PHP -import qualified Language.PHP.Term as PHP -import qualified Language.Python.Syntax as Python -import qualified Language.Python.Term as Python -import qualified Language.Ruby.Syntax as Ruby -import qualified Language.Ruby.Term as Ruby -import qualified Language.TSX.Syntax as TSX -import qualified Language.TSX.Term as TSX -import qualified Language.TypeScript.Syntax as TypeScript -import qualified Language.TypeScript.Term as TypeScript -import Data.Quieterm - -deriving instance AccessControls1 syntax => AccessControls (Term syntax ann) -deriving instance AccessControls (Go.Term ann) -deriving instance AccessControls (PHP.Term ann) -deriving instance AccessControls (Python.Term ann) -deriving instance AccessControls (Ruby.Term ann) -deriving instance AccessControls (TSX.Term ann) -deriving instance AccessControls (TypeScript.Term ann) - -instance (AccessControls recur, AccessControls1 syntax) => AccessControls (TermF syntax ann recur) where - termToAccessControl = liftTermToAccessControl termToAccessControl . termFOut - -instance Apply AccessControls1 fs => AccessControls1 (Sum fs) where - liftTermToAccessControl f = apply @AccessControls1 (liftTermToAccessControl f) - -deriving instance AccessControls1 syntax => AccessControls (Quieterm syntax ann) - -instance AccessControls1 [] -instance AccessControls1 Comment.Comment -instance AccessControls1 Comment.HashBang - -instance AccessControls1 Expression.And -instance AccessControls1 Expression.Await -instance AccessControls1 Expression.BAnd -instance AccessControls1 Expression.BOr -instance AccessControls1 Expression.BXOr -instance AccessControls1 Expression.Call -instance AccessControls1 Expression.Cast -instance AccessControls1 Expression.Comparison -instance AccessControls1 Expression.Complement -instance AccessControls1 Expression.Delete -instance AccessControls1 Expression.DividedBy -instance AccessControls1 Expression.Enumeration -instance AccessControls1 Expression.Equal -instance AccessControls1 Expression.FloorDivision -instance AccessControls1 Expression.GreaterThan -instance AccessControls1 Expression.GreaterThanEqual -instance AccessControls1 Expression.InstanceOf -instance AccessControls1 Expression.LessThan -instance AccessControls1 Expression.LessThanEqual -instance AccessControls1 Expression.LShift -instance AccessControls1 Expression.Matches -instance AccessControls1 Expression.Member -instance AccessControls1 Expression.MemberAccess -instance AccessControls1 Expression.Minus -instance AccessControls1 Expression.Modulo -instance AccessControls1 Expression.Negate -instance AccessControls1 Expression.New -instance AccessControls1 Expression.NonNullExpression -instance AccessControls1 Expression.Not -instance AccessControls1 Expression.NotMatches -instance AccessControls1 Expression.Or -instance AccessControls1 Expression.Plus -instance AccessControls1 Expression.Power -instance AccessControls1 Expression.RShift -instance AccessControls1 Expression.ScopeResolution -instance AccessControls1 Expression.SequenceExpression -instance AccessControls1 Expression.StrictEqual -instance AccessControls1 Expression.Subscript -instance AccessControls1 Expression.Super -instance AccessControls1 Expression.Times -instance AccessControls1 Expression.Typeof -instance AccessControls1 Expression.UnsignedRShift -instance AccessControls1 Expression.Void -instance AccessControls1 Expression.XOr - -instance AccessControls1 Literal.Boolean -instance AccessControls1 Literal.Integer -instance AccessControls1 Literal.Float -instance AccessControls1 Literal.Rational -instance AccessControls1 Literal.Complex -instance AccessControls1 Literal.String -instance AccessControls1 Literal.Character -instance AccessControls1 Literal.InterpolationElement -instance AccessControls1 Literal.TextElement -instance AccessControls1 Literal.EscapeSequence -instance AccessControls1 Literal.Symbol -instance AccessControls1 Literal.SymbolElement -instance AccessControls1 Literal.Regex -instance AccessControls1 Literal.Array -instance AccessControls1 Literal.Hash -instance AccessControls1 Literal.Tuple -instance AccessControls1 Literal.Set -instance AccessControls1 Literal.Pointer -instance AccessControls1 Literal.Reference -instance AccessControls1 Literal.Null -instance AccessControls1 Literal.KeyValue - -instance AccessControls1 Statement.Assignment -instance AccessControls1 Statement.AugmentedAssignment -instance AccessControls1 Statement.Break -instance AccessControls1 Statement.Catch -instance AccessControls1 Statement.Continue -instance AccessControls1 Statement.DoWhile -instance AccessControls1 Statement.Else -instance AccessControls1 Statement.Finally -instance AccessControls1 Statement.For -instance AccessControls1 Statement.ForEach -instance AccessControls1 Statement.Goto -instance AccessControls1 Statement.If -instance AccessControls1 Statement.Let -instance AccessControls1 Statement.Match -instance AccessControls1 Statement.NoOp -instance AccessControls1 Statement.Pattern -instance AccessControls1 Statement.PostDecrement -instance AccessControls1 Statement.PostIncrement -instance AccessControls1 Statement.PreDecrement -instance AccessControls1 Statement.PreIncrement -instance AccessControls1 Statement.Retry -instance AccessControls1 Statement.Return -instance AccessControls1 Statement.ScopeEntry -instance AccessControls1 Statement.ScopeExit -instance AccessControls1 Statement.StatementBlock -instance AccessControls1 Statement.Statements -instance AccessControls1 Statement.Throw -instance AccessControls1 Statement.Try -instance AccessControls1 Statement.While -instance AccessControls1 Statement.Yield - -instance AccessControls1 Syntax.Context -instance AccessControls1 Syntax.Empty -instance AccessControls1 Syntax.Error -instance AccessControls1 Syntax.Identifier -instance AccessControls1 Syntax.AccessibilityModifier - -instance AccessControls1 Type.Annotation -instance AccessControls1 Type.Array -instance AccessControls1 Type.Bool -instance AccessControls1 Type.Double -instance AccessControls1 Type.Float -instance AccessControls1 Type.Function -instance AccessControls1 Type.Int -instance AccessControls1 Type.Interface -instance AccessControls1 Type.Map -instance AccessControls1 Type.Parenthesized -instance AccessControls1 Type.Pointer -instance AccessControls1 Type.Product -instance AccessControls1 Type.Readonly -instance AccessControls1 Type.Slice -instance AccessControls1 Type.TypeParameters -instance AccessControls1 Type.Void - -instance AccessControls1 Declaration.Class -instance AccessControls1 Declaration.Comprehension -instance AccessControls1 Declaration.Constructor -instance AccessControls1 Declaration.Datatype -instance AccessControls1 Declaration.Decorator -instance AccessControls1 Declaration.Function -instance AccessControls1 Declaration.InterfaceDeclaration -instance AccessControls1 Declaration.Method -instance AccessControls1 Declaration.MethodSignature -instance AccessControls1 Declaration.OptionalParameter -instance AccessControls1 Declaration.PublicFieldDefinition -instance AccessControls1 Declaration.RequiredParameter -instance AccessControls1 Declaration.Type -instance AccessControls1 Declaration.TypeAlias -instance AccessControls1 Declaration.Variable -instance AccessControls1 Declaration.VariableDeclaration - -instance AccessControls1 Directive.File -instance AccessControls1 Directive.Line - -instance AccessControls1 Python.Alias -instance AccessControls1 Python.Ellipsis -instance AccessControls1 Python.FutureImport -instance AccessControls1 Python.Import -instance AccessControls1 Python.QualifiedAliasedImport -instance AccessControls1 Python.QualifiedImport -instance AccessControls1 Python.Redirect - -instance AccessControls1 Go.BidirectionalChannel -instance AccessControls1 Go.ReceiveChannel -instance AccessControls1 Go.SendChannel -instance AccessControls1 Go.Import -instance AccessControls1 Go.QualifiedImport -instance AccessControls1 Go.SideEffectImport -instance AccessControls1 Go.Composite -instance AccessControls1 Go.Label -instance AccessControls1 Go.Send -instance AccessControls1 Go.Slice -instance AccessControls1 Go.TypeSwitch -instance AccessControls1 Go.Receive -instance AccessControls1 Go.Field -instance AccessControls1 Go.Package -instance AccessControls1 Go.TypeAssertion -instance AccessControls1 Go.TypeConversion -instance AccessControls1 Go.Variadic -instance AccessControls1 Go.DefaultPattern -instance AccessControls1 Go.Defer -instance AccessControls1 Go.Go -instance AccessControls1 Go.Rune -instance AccessControls1 Go.Select -instance AccessControls1 Go.TypeSwitchGuard -instance AccessControls1 Go.ReceiveOperator - -instance AccessControls1 PHP.Text -instance AccessControls1 PHP.VariableName -instance AccessControls1 PHP.Require -instance AccessControls1 PHP.RequireOnce -instance AccessControls1 PHP.Include -instance AccessControls1 PHP.IncludeOnce -instance AccessControls1 PHP.ArrayElement -instance AccessControls1 PHP.GlobalDeclaration -instance AccessControls1 PHP.SimpleVariable -instance AccessControls1 PHP.Concat -instance AccessControls1 PHP.CastType -instance AccessControls1 PHP.ErrorControl -instance AccessControls1 PHP.Clone -instance AccessControls1 PHP.ShellCommand -instance AccessControls1 PHP.Update -instance AccessControls1 PHP.NewVariable -instance AccessControls1 PHP.RelativeScope -instance AccessControls1 PHP.NamespaceName -instance AccessControls1 PHP.ConstDeclaration -instance AccessControls1 PHP.ClassInterfaceClause -instance AccessControls1 PHP.ClassBaseClause -instance AccessControls1 PHP.UseClause -instance AccessControls1 PHP.ReturnType -instance AccessControls1 PHP.TypeDeclaration -instance AccessControls1 PHP.BaseTypeDeclaration -instance AccessControls1 PHP.ScalarType -instance AccessControls1 PHP.EmptyIntrinsic -instance AccessControls1 PHP.ExitIntrinsic -instance AccessControls1 PHP.IssetIntrinsic -instance AccessControls1 PHP.EvalIntrinsic -instance AccessControls1 PHP.PrintIntrinsic -instance AccessControls1 PHP.NamespaceAliasingClause -instance AccessControls1 PHP.NamespaceUseDeclaration -instance AccessControls1 PHP.NamespaceUseClause -instance AccessControls1 PHP.NamespaceUseGroupClause -instance AccessControls1 PHP.TraitUseSpecification -instance AccessControls1 PHP.Static -instance AccessControls1 PHP.ClassModifier -instance AccessControls1 PHP.InterfaceBaseClause -instance AccessControls1 PHP.Echo -instance AccessControls1 PHP.Unset -instance AccessControls1 PHP.DeclareDirective -instance AccessControls1 PHP.LabeledStatement -instance AccessControls1 PHP.QualifiedName -instance AccessControls1 PHP.ClassConstDeclaration -instance AccessControls1 PHP.Namespace -instance AccessControls1 PHP.TraitDeclaration -instance AccessControls1 PHP.AliasAs -instance AccessControls1 PHP.InsteadOf -instance AccessControls1 PHP.TraitUseClause -instance AccessControls1 PHP.DestructorDeclaration -instance AccessControls1 PHP.ConstructorDeclaration -instance AccessControls1 PHP.PropertyDeclaration -instance AccessControls1 PHP.PropertyModifier -instance AccessControls1 PHP.InterfaceDeclaration -instance AccessControls1 PHP.Declare - -instance AccessControls1 Ruby.Assignment -instance AccessControls1 Ruby.Class -instance AccessControls1 Ruby.Send -instance AccessControls1 Ruby.Require -instance AccessControls1 Ruby.Load -instance AccessControls1 Ruby.LowPrecedenceAnd -instance AccessControls1 Ruby.LowPrecedenceOr -instance AccessControls1 Ruby.Module -instance AccessControls1 Ruby.ZSuper - -instance AccessControls1 TSX.JsxElement -instance AccessControls1 TSX.JsxOpeningElement -instance AccessControls1 TSX.JsxSelfClosingElement -instance AccessControls1 TSX.JsxAttribute -instance AccessControls1 TSX.JsxNamespaceName -instance AccessControls1 TSX.JsxText -instance AccessControls1 TSX.JsxExpression -instance AccessControls1 TSX.JsxClosingElement -instance AccessControls1 TSX.JsxFragment - -instance AccessControls1 TypeScript.AnnotatedExpression -instance AccessControls1 TypeScript.JavaScriptRequire -instance AccessControls1 TypeScript.Debugger -instance AccessControls1 TypeScript.Super -instance AccessControls1 TypeScript.Undefined -instance AccessControls1 TypeScript.With -instance AccessControls1 TypeScript.OptionalParameter -instance AccessControls1 TypeScript.RequiredParameter -instance AccessControls1 TypeScript.RestParameter -instance AccessControls1 TypeScript.ImplementsClause -instance AccessControls1 TypeScript.Import -instance AccessControls1 TypeScript.QualifiedAliasedImport -instance AccessControls1 TypeScript.QualifiedExportFrom -instance AccessControls1 TypeScript.LookupType -instance AccessControls1 TypeScript.Union -instance AccessControls1 TypeScript.Intersection -instance AccessControls1 TypeScript.FunctionType -instance AccessControls1 TypeScript.AmbientFunction -instance AccessControls1 TypeScript.ImportRequireClause -instance AccessControls1 TypeScript.Constructor -instance AccessControls1 TypeScript.TypeParameter -instance AccessControls1 TypeScript.TypeAssertion -instance AccessControls1 TypeScript.NestedIdentifier -instance AccessControls1 TypeScript.NestedTypeIdentifier -instance AccessControls1 TypeScript.GenericType -instance AccessControls1 TypeScript.TypePredicate -instance AccessControls1 TypeScript.EnumDeclaration -instance AccessControls1 TypeScript.PropertySignature -instance AccessControls1 TypeScript.CallSignature -instance AccessControls1 TypeScript.ConstructSignature -instance AccessControls1 TypeScript.IndexSignature -instance AccessControls1 TypeScript.AbstractMethodSignature -instance AccessControls1 TypeScript.ForOf -instance AccessControls1 TypeScript.LabeledStatement -instance AccessControls1 TypeScript.InternalModule -instance AccessControls1 TypeScript.ImportAlias -instance AccessControls1 TypeScript.ClassHeritage -instance AccessControls1 TypeScript.AbstractClass -instance AccessControls1 TypeScript.SideEffectImport -instance AccessControls1 TypeScript.QualifiedExport -instance AccessControls1 TypeScript.DefaultExport -instance AccessControls1 TypeScript.ShorthandPropertyIdentifier -instance AccessControls1 TypeScript.ImportClause -instance AccessControls1 TypeScript.Tuple -instance AccessControls1 TypeScript.Annotation -instance AccessControls1 TypeScript.Decorator -instance AccessControls1 TypeScript.ComputedPropertyName -instance AccessControls1 TypeScript.Constraint -instance AccessControls1 TypeScript.DefaultType -instance AccessControls1 TypeScript.ParenthesizedType -instance AccessControls1 TypeScript.PredefinedType -instance AccessControls1 TypeScript.TypeIdentifier -instance AccessControls1 TypeScript.ObjectType -instance AccessControls1 TypeScript.AmbientDeclaration -instance AccessControls1 TypeScript.ExtendsClause -instance AccessControls1 TypeScript.ArrayType -instance AccessControls1 TypeScript.FlowMaybeType -instance AccessControls1 TypeScript.TypeQuery -instance AccessControls1 TypeScript.IndexTypeQuery -instance AccessControls1 TypeScript.TypeArguments -instance AccessControls1 TypeScript.ThisType -instance AccessControls1 TypeScript.ExistentialType -instance AccessControls1 TypeScript.LiteralType -instance AccessControls1 TypeScript.Update -instance AccessControls1 TypeScript.MetaProperty -instance AccessControls1 TypeScript.Module diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs deleted file mode 100644 index aaaf91a015..0000000000 --- a/src/Data/Abstract/Address/Hole.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Abstract.Address.Hole -( Hole(..) -, toMaybe -) where - -import Control.Abstract -import Control.Algebra -import Data.Semilattice.Lower - -data Hole context a = Partial context | Total a - deriving (Foldable, Functor, Eq, Ord, Show, Traversable) - -instance Lower context => AbstractHole (Hole context a) where - hole = Partial lowerBound - -toMaybe :: Hole context a -> Maybe a -toMaybe (Partial _) = Nothing -toMaybe (Total a) = Just a - - -promoteA :: AllocatorC address m a -> AllocatorC (Hole context address) m a -promoteA = AllocatorC . runAllocatorC - -instance ( Algebra (Allocator address :+: sig) (AllocatorC address m) - , Algebra sig m - , Monad m - ) - => Algebra (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where - alg (R other) = AllocatorC . alg . handleCoercible $ other - alg (L (Alloc name k)) = Total <$> promoteA (alg (L (Alloc name pure))) >>= k - - -promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a -promoteD = DerefC . runDerefC - -instance (Algebra (Deref value :+: sig) (DerefC address value m), Algebra sig m) - => Algebra (Deref value :+: sig) (DerefC (Hole context address) value m) where - alg (R other) = DerefC . alg . handleCoercible $ other - alg (L op) = case op of - DerefCell cell k -> promoteD (alg (L (DerefCell cell pure))) >>= k - AssignCell value cell k -> promoteD (alg (L (AssignCell value cell pure))) >>= k diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs deleted file mode 100644 index b060d578a1..0000000000 --- a/src/Data/Abstract/Address/Monovariant.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Abstract.Address.Monovariant -( Monovariant(..) -) where - -import Analysis.Name -import Control.Abstract -import Control.Algebra -import Data.Foldable -import Data.Functor.Classes -import Data.List.NonEmpty (nonEmpty) -import qualified Data.Set as Set - --- | 'Monovariant' models using one address for a particular name. It tracks the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new. -newtype Monovariant = Monovariant { unMonovariant :: Name } - deriving (Eq, Ord) - -instance Show Monovariant where - showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant - - -instance Algebra sig m => Algebra (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where - alg (L (Alloc name k)) = k (Monovariant name) - alg (R other) = AllocatorC . alg . handleCoercible $ other - -instance (Ord value, Algebra sig m, Alternative m, Monad m) => Algebra (Deref value :+: sig) (DerefC Monovariant value m) where - alg (L (DerefCell cell k)) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= k - alg (L (AssignCell value cell k)) = k (Set.insert value cell) - alg (R other) = DerefC . alg . handleCoercible $ other diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs deleted file mode 100644 index 362bc63d7d..0000000000 --- a/src/Data/Abstract/Address/Precise.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Abstract.Address.Precise -( Precise(..) -) where - -import Control.Abstract -import Control.Algebra -import Data.Functor.Classes -import qualified Data.Set as Set - --- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store. -newtype Precise = Precise { unPrecise :: Int } - deriving (Eq, Ord) - -instance Show Precise where - showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise - - -instance Has Fresh sig m => Algebra (Allocator Precise :+: sig) (AllocatorC Precise m) where - alg (R other) = AllocatorC . alg . handleCoercible $ other - alg (L (Alloc _ k)) = Precise <$> fresh >>= k - - -instance Algebra sig m => Algebra (Deref value :+: sig) (DerefC Precise value m) where - alg (R other) = DerefC . alg . handleCoercible $ other - alg (L op) = case op of - DerefCell cell k -> k (fst <$> Set.minView cell) - AssignCell value _ k -> k (Set.singleton value) diff --git a/src/Data/Abstract/BaseError.hs b/src/Data/Abstract/BaseError.hs deleted file mode 100644 index 3038667780..0000000000 --- a/src/Data/Abstract/BaseError.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RecordWildCards #-} -module Data.Abstract.BaseError ( - BaseError(..) -, throwBaseError -) -where - -import Control.Abstract.Context -import Control.Abstract.Evaluator -import qualified Data.Abstract.Module as M -import Data.Functor.Classes -import qualified Source.Span as S -import qualified System.Path as Path - -data BaseError (exc :: * -> *) resume = BaseError { baseErrorModuleInfo :: ModuleInfo, baseErrorSpan :: Span, baseErrorException :: exc resume } - -instance (Show (exc resume)) => Show (BaseError exc resume) where - showsPrec _ BaseError{..} = shows baseErrorException <> showString " " <> showString errorLocation - where errorLocation | startErrorLine == endErrorLine = baseModuleFilePath <> " " <> startErrorLine <> ":" <> startErrorCol <> "-" <> endErrorCol - | otherwise = baseModuleFilePath <> " " <> startErrorLine <> ":" <> startErrorCol <> "-" <> endErrorLine <> ":" <> endErrorCol - baseModuleFilePath = Path.toString $ M.modulePath baseErrorModuleInfo - startErrorLine = show $ S.line (S.start baseErrorSpan) - endErrorLine = show $ S.line (S.end baseErrorSpan) - startErrorCol = show $ S.column (S.start baseErrorSpan) - endErrorCol = show $ S.column (S.end baseErrorSpan) - -instance (Eq1 exc) => Eq1 (BaseError exc) where - liftEq f (BaseError info1 span1 exc1) (BaseError info2 span2 exc2) = info1 == info2 && span1 == span2 && liftEq f exc1 exc2 - -instance Show1 exc => Show1 (BaseError exc) where - liftShowsPrec sl sp d (BaseError info span exc) = showParen (d > 10) $ showString "BaseError" . showChar ' ' . showsPrec 11 info . showChar ' ' . showsPrec 11 span . showChar ' ' . liftShowsPrec sl sp 11 exc - -throwBaseError :: ( Has (Resumable (BaseError exc)) sig m - , Has (Reader M.ModuleInfo) sig m - , Has (Reader S.Span) sig m - ) - => exc resume - -> m resume -throwBaseError err = do - moduleInfo <- currentModule - span <- currentSpan - throwResumable $ BaseError moduleInfo span err diff --git a/src/Data/Abstract/Declarations.hs b/src/Data/Abstract/Declarations.hs deleted file mode 100644 index 48fb240fae..0000000000 --- a/src/Data/Abstract/Declarations.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeApplications, UndecidableInstances #-} -module Data.Abstract.Declarations - ( Declarations (..) - , Declarations1 (..) - ) where - -import Analysis.Name -import Data.Sum -import Data.Term - -class Declarations syntax where - declaredName :: syntax -> Maybe Name - declaredName = const Nothing - - declaredAlias :: syntax -> Maybe Name - declaredAlias = const Nothing - -class Declarations1 syntax where - -- | Lift a function mapping each element to its declared name (if any) through a containing structure. This can be used to define the declared name for a composite piece of syntax in terms of the declared name of one of its components. - -- - -- Note that not all syntax will have a declared name; in general it’s reserved for syntax where the user has provided a single, unambiguous name for whatever term is being introduced. Examples would be (non-anonymous) functions, methods, and classes; but not (generally) literals or blocks of imperative statements. - liftDeclaredName :: (a -> Maybe Name) -> syntax a -> Maybe Name - liftDeclaredName _ _ = Nothing - - liftDeclaredAlias :: (a -> Maybe Name) -> syntax a -> Maybe Name - liftDeclaredAlias _ _ = Nothing - -deriving instance Declarations1 syntax => Declarations (Term syntax ann) - -instance (Declarations recur, Declarations1 syntax) => Declarations (TermF syntax ann recur) where - declaredName = liftDeclaredName declaredName . termFOut - declaredAlias = liftDeclaredAlias declaredAlias . termFOut - -instance Apply Declarations1 fs => Declarations1 (Sum fs) where - liftDeclaredName f = apply @Declarations1 (liftDeclaredName f) - liftDeclaredAlias f = apply @Declarations1 (liftDeclaredAlias f) - -instance Declarations1 [] diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs deleted file mode 100644 index 340dd5e523..0000000000 --- a/src/Data/Abstract/Evaluatable.hs +++ /dev/null @@ -1,354 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Abstract.Evaluatable -( module X -, Evaluatable(..) -, traceResolve --- * Preludes -, HasPrelude(..) --- * Effects -, EvalError(..) -, throwEvalError -, throwNoNameError -, runEvalError -, runEvalErrorWith -, UnspecializedError(..) -, runUnspecialized -, runUnspecializedWith -, throwUnspecializedError -, __self -) where - -import Control.Algebra -import qualified Control.Carrier.Resumable.Either as Either -import qualified Control.Carrier.Resumable.Resume as With -import Data.Foldable -import Data.Functor.Classes -import Data.List.NonEmpty (nonEmpty) -import Data.Scientific (Scientific) -import Data.Semigroup.Foldable -import Data.Sum -import Data.Text -import GHC.Stack -import Source.Span (HasSpan (..), Pos (..), point) - -import Analysis.Name as X -import Control.Abstract hiding (Load, String) -import qualified Control.Abstract as Abstract -import Control.Abstract.Context as X -import Control.Abstract.Evaluator as X hiding - (LoopControl (..), Return (..), catchLoopControl, catchReturn, runLoopControl, runReturn) -import Control.Abstract.Modules as X - ( ModuleResult - , Modules - , ResolutionError (..) - , listModulesInDir - , load - , lookupModule - , require - , resolve - , throwResolutionError - ) -import Control.Abstract.Value as X hiding - ( Array (..) - , Bitwise (..) - , Boolean (..) - , Function (..) - , Hash (..) - , Numeric (..) - , Object (..) - , String (..) - , Unit (..) - , While (..) - ) -import Data.Abstract.AccessControls.Class as X -import Data.Abstract.BaseError as X -import Data.Abstract.Declarations as X -import Data.Abstract.FreeVariables as X -import Data.Abstract.Module -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Language -import Data.Semigroup.App -import Data.Term - --- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. -class (Show1 constr, Foldable constr) => Evaluatable constr where - eval :: ( AbstractValue term address value m - , AccessControls term - , Declarations term - , FreeVariables term - , HasSpan term - , Has (Allocator address) sig m - , Has (Bitwise value) sig m - , Has (Boolean value) sig m - , Has (While value) sig m - , Has (Deref value) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Error (LoopControl value)) sig m - , Has (Error (Return value)) sig m - , Has Fresh sig m - , Has (Function term address value) sig m - , Has (Modules address value) sig m - , Has (Numeric value) sig m - , Has (Object address value) sig m - , Has (Array value) sig m - , Has (Hash value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader PackageInfo) sig m - , Has (Reader Span) sig m - , Has (State Span) sig m - , Has (Abstract.String value) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Resumable (BaseError (AddressError address value))) sig m - , Has (Resumable (BaseError (UnspecializedError address value))) sig m - , Has (Resumable (BaseError (EvalError term address value))) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - , Has (State (Heap address address value)) sig m - , Has Trace sig m - , Has (Unit value) sig m - , Ord address - , Show address - ) - => (term -> Evaluator term address value m value) - -> (term -> Evaluator term address value m (Slot address)) - -> (constr term -> Evaluator term address value m value) - eval recur _ expr = do - traverse_ recur expr - throwUnspecializedError $ UnspecializedError ("Eval unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "") - - ref :: ( AbstractValue term address value m - , Declarations term - , Has (Object address value) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (EvalError term address value))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (UnspecializedError address value))) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Ord address - ) - => (term -> Evaluator term address value m value) - -> (term -> Evaluator term address value m (Slot address)) - -> (constr term -> Evaluator term address value m (Slot address)) - ref _ _ expr = do - throwUnspecializedError $ RefUnspecializedError ("ref unspecialized for " <> liftShowsPrec (const (const id)) (const id) 0 expr "") - - -traceResolve :: (Show a, Show b, Has Trace sig m) => a -> b -> Evaluator term address value m () -traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) - -__self :: Name -__self = name "__semantic_self" - --- Preludes - -class HasPrelude (language :: Language) where - definePrelude :: ( AbstractValue term address value m - , HasCallStack - , Has (Allocator address) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Deref value) sig m - , Has Fresh sig m - , Has (Function term address value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (AddressError address value))) sig m - , Has (State (Heap address address value)) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has Trace sig m - , Has (Unit value) sig m - , Has (Object address value) sig m - , Ord address - , Show address - ) - => proxy language - -> Evaluator term address value m () - definePrelude _ = pure () - -instance HasPrelude 'Go -instance HasPrelude 'Haskell -instance HasPrelude 'Java -instance HasPrelude 'PHP - -instance HasPrelude 'Python where - definePrelude _ = - defineBuiltIn (Declaration $ X.name "print") Default Public Print - -instance HasPrelude 'Ruby where - definePrelude _ = do - defineSelf - - defineBuiltIn (Declaration $ X.name "puts") Default Public Print - - defineClass (Declaration (X.name "Object")) [] $ do - defineBuiltIn (Declaration $ X.name "inspect") Default Public Show - -instance HasPrelude 'TSX - -instance HasPrelude 'TypeScript where - definePrelude _ = do - defineSelf - defineNamespace (Declaration (X.name "console")) $ defineBuiltIn (Declaration $ X.name "log") Default Public Print - -instance HasPrelude 'JavaScript where - definePrelude _ = do - defineSelf - defineNamespace (Declaration (X.name "console")) $ defineBuiltIn (Declaration $ X.name "log") Default Public Print - -defineSelf :: ( Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Deref value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State (Heap address address value)) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Object address value) sig m - , Ord address - ) - => Evaluator term address value m () -defineSelf = do - let self = Declaration __self - declare self ScopeGraph.Prelude Public (point (Pos 1 1)) ScopeGraph.Unknown Nothing - slot <- lookupSlot self - assign slot =<< object =<< currentFrame - - --- Effects - --- | The type of error thrown when failing to evaluate a term. -data EvalError term address value return where - AccessControlError :: (Name, AccessControl) -> (Name, AccessControl) -> value -> EvalError term address value value - ConstructorError :: Name -> EvalError term address value address - DefaultExportError :: EvalError term address value () - DerefError :: value -> EvalError term address value value - ExportError :: ModulePath -> Name -> EvalError term address value () - FloatFormatError :: Text -> EvalError term address value Scientific - -- Indicates that our evaluator wasn't able to make sense of these literals. - IntegerFormatError :: Text -> EvalError term address value Integer - NoNameError :: term -> EvalError term address value Name - RationalFormatError :: Text -> EvalError term address value Rational - ReferenceError :: value -> term -> EvalError term address value (Slot address) - ScopedEnvError :: value -> EvalError term address value address - -throwNoNameError :: ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (EvalError term address value))) sig m - ) - => term - -> Evaluator term address value m Name -throwNoNameError = throwEvalError . NoNameError - -deriving instance (Eq term, Eq value) => Eq (EvalError term address value return) -deriving instance (Show term, Show value) => Show (EvalError term address value return) - -instance (Eq term, Eq value) => Eq1 (EvalError term address value) where - liftEq _ (AccessControlError a b c) (AccessControlError a' b' c') = a == a' && b == b' && c == c' - liftEq _ (DerefError v) (DerefError v2) = v == v2 - liftEq _ DefaultExportError DefaultExportError = True - liftEq _ (ExportError a b) (ExportError c d) = a == c && b == d - liftEq _ (FloatFormatError a) (FloatFormatError b) = a == b - liftEq _ (IntegerFormatError a) (IntegerFormatError b) = a == b - liftEq _ (NoNameError t1) (NoNameError t2) = t1 == t2 - liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b - liftEq _ (ReferenceError v n) (ReferenceError v2 n2) = v == v2 && n == n2 - liftEq _ _ _ = False - -instance (Show term, Show value) => Show1 (EvalError term address value) where - liftShowsPrec _ _ = showsPrec - -runEvalError :: Evaluator term address value (Either.ResumableC (BaseError (EvalError term address value)) m) a - -> Evaluator term address value m (Either (Either.SomeError (BaseError (EvalError term address value))) a) -runEvalError = raiseHandler Either.runResumable - -runEvalErrorWith :: (forall resume . (BaseError (EvalError term address value)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (With.ResumableC (BaseError (EvalError term address value)) m) a - -> Evaluator term address value m a -runEvalErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) - -throwEvalError :: ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (EvalError term address value))) sig m - ) - => EvalError term address value resume - -> Evaluator term address value m resume -throwEvalError = throwBaseError - - -data UnspecializedError address value resume where - UnspecializedError :: String -> UnspecializedError address value value - RefUnspecializedError :: String -> UnspecializedError address value (Slot address) - -deriving instance Eq (UnspecializedError address value resume) -deriving instance Show (UnspecializedError address value resume) - - -instance Eq1 (UnspecializedError address value) where - liftEq _ (UnspecializedError a) (UnspecializedError b) = a == b - liftEq _ (RefUnspecializedError a) (RefUnspecializedError b) = a == b - liftEq _ _ _ = False - -instance Show1 (UnspecializedError address value) where - liftShowsPrec _ _ = showsPrec - -runUnspecialized :: Evaluator term address value (Either.ResumableC (BaseError (UnspecializedError address value)) m) a - -> Evaluator term address value m (Either (Either.SomeError (BaseError (UnspecializedError address value))) a) -runUnspecialized = raiseHandler Either.runResumable - -runUnspecializedWith :: (forall resume . BaseError (UnspecializedError address value) resume -> Evaluator term address value m resume) - -> Evaluator term address value (With.ResumableC (BaseError (UnspecializedError address value)) m) a - -> Evaluator term address value m a -runUnspecializedWith f = raiseHandler $ With.runResumable (runEvaluator . f) - - -throwUnspecializedError :: ( Has (Resumable (BaseError (UnspecializedError address value))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - ) - => UnspecializedError address value resume - -> Evaluator term address value m resume -throwUnspecializedError = throwBaseError - - --- Instances - --- | If we can evaluate any syntax which can occur in a 'Sum', we can evaluate the 'Sum'. -instance (Apply Evaluatable fs, Apply Show1 fs, Apply Foldable fs) => Evaluatable (Sum fs) where - eval eval' ref = apply @Evaluatable (eval eval' ref) - ref eval ref' = apply @Evaluatable (ref eval ref') - --- | Evaluating a 'TermF' ignores its annotation, evaluating the underlying syntax. -instance (Evaluatable s, Show a) => Evaluatable (TermF s a) where - eval eval' ref = eval eval' ref . termFOut - ref eval ref' = ref eval ref' . termFOut - - --- NOTE: Use 'Data.Syntax.Statements' instead of '[]' if you need imperative eval semantics. --- --- | '[]' is treated as an imperative sequence of statements/declarations s.t.: --- --- 1. Each statement’s effects on the store are accumulated; --- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and --- 3. Only the last statement’s return value is returned. -instance Evaluatable [] where - -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists. - eval eval _ = maybe unit (runApp . foldMap1 (App . eval)) . nonEmpty diff --git a/src/Data/Abstract/FreeVariables.hs b/src/Data/Abstract/FreeVariables.hs deleted file mode 100644 index 85c6223b50..0000000000 --- a/src/Data/Abstract/FreeVariables.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Abstract.FreeVariables - ( FreeVariables (..) - , FreeVariables1 (..) - ) where - -import Analysis.Name -import Data.Set (Set) -import Data.Sum -import Data.Term - --- | Types which can contain unbound variables. -class FreeVariables term where - -- | The set of free variables in the given value. - freeVariables :: term -> Set Name - - --- | A lifting of 'FreeVariables' to type constructors of kind @* -> *@. --- --- 'Foldable' types requiring no additional semantics to the set of free variables (e.g. types which do not bind any variables) can use (and even derive, with @-XDeriveAnyClass@) the default implementation. -class FreeVariables1 syntax where - -- | Lift a function mapping each element to its set of free variables through a containing structure, collecting the results into a single set. - liftFreeVariables :: (a -> Set Name) -> syntax a -> Set Name - default liftFreeVariables :: (Foldable syntax) => (a -> Set Name) -> syntax a -> Set Name - liftFreeVariables = foldMap - -deriving instance FreeVariables1 syntax => FreeVariables (Term syntax ann) - -instance (FreeVariables recur, FreeVariables1 syntax) => FreeVariables (TermF syntax ann recur) where - freeVariables = liftFreeVariables freeVariables - -instance FreeVariables1 syntax => FreeVariables1 (TermF syntax ann) where - liftFreeVariables f (In _ s) = liftFreeVariables f s - -instance Apply FreeVariables1 fs => FreeVariables1 (Sum fs) where - liftFreeVariables f = apply @FreeVariables1 (liftFreeVariables f) - -instance FreeVariables1 [] diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs deleted file mode 100644 index 2e47d70fb3..0000000000 --- a/src/Data/Abstract/Heap.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -module Data.Abstract.Heap - ( Heap(..) - , Frame(..) - , frameLookup - , scopeLookup - , frameSlots - , frameLinks - , getSlotValue - , setSlot - , deleteSlot - , initFrame - , newFrame - , insertFrame - , heapLookup - , heapLookupAll - , heapSize - , heapRestrict - , Position(..) - , pathPosition - , pathDeclaration - , lookupFrameAddress - , lookupDeclaration - , isHeapEmpty - ) where - -import Data.Abstract.Live -import Data.Abstract.ScopeGraph - ( Declaration (..) - , EdgeLabel (..) - , Path (..) - , Position (..) - , ScopeGraph - , Slot (..) - , lookupScopePath - , pathDeclaration - , pathPosition - ) -import Data.Foldable -import Data.Functor.Classes -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Semilattice.Lower -import Data.Set (Set) -import Prelude hiding (lookup) - --- | A Frame describes the vertices of the Heap. Think of it as an instance of a Scope in the ScopeGraph. -data Frame scopeAddress frameAddress value = Frame - { scopeAddress :: scopeAddress - -- ^ The scope address of its corresponding Scope - , links :: Map EdgeLabel (Map scopeAddress frameAddress) - -- ^ A map of edge labels to maps of scope addresses to frame addresses (scope addresses are unique keys in the ScopeGraph - -- and frame addresses are unique keys in the Heap). This map describes the frame’s links to other frames. - -- A frame’s links are always in one-to-one correspondence with its scope’s edges to parent scopes. - , slots :: IntMap (Set value) - -- ^ An IntMap of values that are declared in the frame. - } - deriving (Eq, Ord, Show) - --- | A Heap is a Map from frame addresses to frames. -newtype Heap scopeAddress frameAddress value = Heap { unHeap :: Map frameAddress (Frame scopeAddress frameAddress value) } - deriving (Eq, Lower, Ord) - - --- | Look up the frame for an 'address' in a 'Heap', if any. -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 value -> Maybe scope -scopeLookup address = fmap scopeAddress . frameLookup address - -frameSlots :: Ord address => address -> Heap scope address value -> Maybe (IntMap (Set value)) -frameSlots address = fmap slots . frameLookup address - -frameLinks :: Ord address => address -> Heap scope address value -> Maybe (Map EdgeLabel (Map scope address)) -frameLinks address = fmap links . frameLookup address - -getSlotValue :: Ord address => Slot address -> Heap address address value -> Maybe (Set value) -getSlotValue Slot{..} = (IntMap.lookup (unPosition position) =<<) . frameSlots frameAddress - -setSlot :: Ord address => Slot address -> Set value -> Heap scope address value -> Heap scope address value -setSlot Slot{..} value h@(Heap heap) = case frameLookup frameAddress h of - Just frame -> let slotMap = slots frame in - Heap (Map.insert frameAddress (frame { slots = IntMap.insert (unPosition position) value slotMap }) heap) - Nothing -> h - -deleteSlot :: Ord address => Slot address -> Heap scope address value -> Heap scope address value -deleteSlot Slot{..} h@(Heap heap) = case frameLookup frameAddress h of - Just frame -> let slotMap = slots frame in - Heap (Map.insert frameAddress (frame { slots = IntMap.delete (unPosition position) slotMap }) heap) - Nothing -> h - -lookupDeclaration :: Ord address - => Declaration - -> (address, address) - -> ScopeGraph address - -> Heap address address value - -> Maybe (Slot address) -lookupDeclaration Declaration{..} (currentScope, currentFrame) scopeGraph heap = do - path <- lookupScopePath unDeclaration currentScope scopeGraph - frameAddress <- lookupFrameAddress path currentFrame heap - pure (Slot frameAddress (pathPosition path)) - -lookupFrameAddress :: (Ord address, Ord scope) => Path scope -> address -> Heap scope address value -> Maybe address -lookupFrameAddress path currentFrame h = go path currentFrame - where - go path address = case path of - DPath _ _ -> pure address - EPath edge nextScopeAddress path' -> do - linkMap <- frameLinks address h - frameAddress <- do - scopeMap <- Map.lookup edge linkMap - Map.lookup nextScopeAddress scopeMap - go path' frameAddress - Hole -> Nothing - -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) => scope -> address -> Map EdgeLabel (Map scope address) -> IntMap (Set 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 value -> Heap scope address value -> Heap scope address value -insertFrame address frame = Heap . Map.insert address frame . unHeap - -fillFrame :: Ord address => address -> IntMap (Set 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 - --- | Look up the cell of values for an address in a 'Heap', if any. -heapLookup :: (Ord address, Ord value) => address -> Heap address address value -> Maybe (Set value) -heapLookup address = fmap (fold . IntMap.elems . slots) . Map.lookup address . unHeap - --- | Look up the list of values stored for a given address, if any. -heapLookupAll :: (Ord address, Ord value) => address -> Heap address address value -> Maybe [value] -heapLookupAll address = fmap toList . heapLookup address - --- | The number of frames in the `Heap`. -heapSize :: Heap scope address value -> Int -heapSize = Map.size . unHeap - --- | Restrict a 'Heap' to only those addresses in the given 'Live' set (in essence garbage collecting the rest). -heapRestrict :: Ord address => Heap address address value -> Live address -> Heap address address value -heapRestrict (Heap m) roots = Heap (Map.filterWithKey (\ address _ -> address `liveMember` roots) m) - --- | Checks whether a heap as no slots and links. -isHeapEmpty :: (Eq address, Eq value) => Heap scope address value -> Bool -isHeapEmpty h@(Heap heap) - = heapSize h == 1 - && (toEmptyFrame <$> Map.elems heap) == [ Frame () mempty mempty ] - where - -- Maps a frame's address param to () so we can check that its slots and links are empty. - toEmptyFrame Frame{..} = Frame () (Map.mapKeysMonotonic (const ()) <$> links) slots - - -instance (Show address, Show value) => Show (Heap address address value) where - showsPrec d = showsUnaryWith showsPrec "Heap" d . Map.toList . unHeap diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs deleted file mode 100644 index 968809ff2c..0000000000 --- a/src/Data/Abstract/Live.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Data.Abstract.Live - ( Live (..) - , fromAddresses - , liveSingleton - , liveInsert - , liveDelete - , liveDifference - , liveMember - , liveSplit - , liveMap - ) where - -import Data.Function -import Data.Functor.Classes -import Data.Semilattice.Lower -import Data.Set as Set hiding (foldr) - --- | A set of live addresses (whether roots or reachable). -newtype Live address = Live { unLive :: Set address } - deriving (Eq, Lower, Monoid, Ord, Semigroup) - -fromAddresses :: (Foldable t, Ord address) => t address -> Live address -fromAddresses = foldr liveInsert lowerBound - --- | Construct a 'Live' set containing only the given address. -liveSingleton :: address -> Live address -liveSingleton = Live . Set.singleton - --- | Insert an address into a 'Live' set. -liveInsert :: Ord address => address -> Live address -> Live address -liveInsert addr = Live . Set.insert addr . unLive - --- | Delete an address from a 'Live' set, if present. -liveDelete :: Ord address => address -> Live address -> Live address -liveDelete addr = Live . Set.delete addr . unLive - --- | Compute the (asymmetric) difference of two 'Live' sets, i.e. delete every element of the second set from the first set. -liveDifference :: Ord address => Live address -> Live address -> Live address -liveDifference = fmap Live . (Set.difference `on` unLive) - --- | Test whether an address is in a 'Live' set. -liveMember :: Ord address => address -> Live address -> Bool -liveMember addr = Set.member addr . unLive - --- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty. -liveSplit :: Live address -> Maybe (address, Live address) -liveSplit = fmap (fmap Live) . Set.minView . unLive - --- | Map a function over the addresses in a 'Live' set. -liveMap :: Ord b => (a -> b) -> Live a -> Live b -liveMap f = Live . Set.map f . unLive - - -instance Show address => Show (Live address) where - showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive diff --git a/src/Data/Abstract/Module.hs b/src/Data/Abstract/Module.hs deleted file mode 100644 index 373933339b..0000000000 --- a/src/Data/Abstract/Module.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Data.Abstract.Module - ( module X - ) where - -import Data.Module as X diff --git a/src/Data/Abstract/ModuleTable.hs b/src/Data/Abstract/ModuleTable.hs deleted file mode 100644 index 3a08758933..0000000000 --- a/src/Data/Abstract/ModuleTable.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.Abstract.ModuleTable -( ModulePath -, ModuleTable (..) -, singleton -, lookup -, member -, modulePaths -, modulePathsInDir -, insert -, keys -, fromModules -, toPairs -) where - -import Data.Abstract.Module -import Data.Functor.Classes -import qualified Data.Map as Map -import Data.Semilattice.Lower -import Data.Set (Set) -import Prelude hiding (lookup) -import qualified System.Path as Path - -newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModulePath a } - deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Traversable) - -singleton :: ModulePath -> a -> ModuleTable a -singleton name = ModuleTable . Map.singleton name - -modulePaths :: ModuleTable a -> Set ModulePath -modulePaths = Map.keysSet . unModuleTable - -modulePathsInDir :: FilePath -> ModuleTable a -> [ModulePath] -modulePathsInDir k = filter (\e -> Path.absRel k == Path.takeDirectory e) . Map.keys . unModuleTable - -lookup :: ModulePath -> ModuleTable a -> Maybe a -lookup k = Map.lookup k . unModuleTable - -member :: ModulePath -> ModuleTable a -> Bool -member k = Map.member k . unModuleTable - -insert :: ModulePath -> a -> ModuleTable a -> ModuleTable a -insert k v = ModuleTable . Map.insert k v . unModuleTable - -keys :: ModuleTable a -> [ModulePath] -keys = Map.keys . unModuleTable - --- | Construct a 'ModuleTable' from a non-empty list of 'Module's. -fromModules :: [Module term] -> ModuleTable (Module term) -fromModules = ModuleTable . Map.fromList . map toEntry - where toEntry m = (modulePath (moduleInfo m), m) - -toPairs :: ModuleTable a -> [(ModulePath, a)] -toPairs = Map.toList . unModuleTable - - -instance Show a => Show (ModuleTable a) where - showsPrec d = showsUnaryWith showsPrec "ModuleTable" d . toPairs diff --git a/src/Data/Abstract/Number.hs b/src/Data/Abstract/Number.hs deleted file mode 100644 index bf276b0281..0000000000 --- a/src/Data/Abstract/Number.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} - -module Data.Abstract.Number - ( Number (..) - , SomeNumber (..) - , liftReal - , liftIntegralFrac - , liftedExponent - , liftedFloorDiv - ) where - -import Data.Function (on) -import Data.Scientific -import Prelude hiding (Integer) -import qualified Prelude - --- | A generalized number type that unifies all interpretable numeric types. --- This is a GADT, so you can specialize the 'a' parameter and be confident --- that, say, a @Number Scientific@ contains a 'Scientific' and not an integer --- in disguise. This unified type is used to provide mathematical operations --- that can change their representation based on an operation's operands—e.g. --- raising a rational number to a ratio may not produce another rational number. --- This also neatly encapsulates the "coalescing" behavior of adding numbers --- of different type in dynamic languages: operating on a whole and a rational --- produces a rational, operating on a rational and a decimal produces a decimal, --- and so on and so forth. When we add complex numbers, they will in turn subsume --- the other numeric types. -data Number a where - Integer :: !Prelude.Integer -> Number Prelude.Integer - Ratio :: !Prelude.Rational -> Number Prelude.Rational - Decimal :: !Scientific -> Number Scientific - -deriving instance Eq a => Eq (Number a) - -instance Show (Number a) where - show (Integer i) = show i - show (Ratio r) = show r - show (Decimal d) = show d - --- | Every 'Number' can be coerced to a 'Scientific'. Used in the 'Ord' instance. -toScientific :: Number a -> Scientific -toScientific (Integer i) = fromInteger i -toScientific (Ratio r) = fromRational r -toScientific (Decimal s) = s - -instance Eq a => Ord (Number a) where compare = compare `on` toScientific - --- | A box that hides the @a@ parameter to a given 'Number'. Pattern-match --- on it to extract the information contained; because there are only three --- possible constructors, pattern-matching all three cases is possible. -data SomeNumber = forall a . SomeNumber (Number a) - --- | Smart constructors for 'SomeNumber'. -whole :: Prelude.Integer -> SomeNumber -whole = SomeNumber . Integer - -ratio :: Prelude.Rational -> SomeNumber -ratio = SomeNumber . Ratio - -decim :: Scientific -> SomeNumber -decim = SomeNumber . Decimal - --- | In order to provide truly generic math operations, where functions like --- exponentiation handle the fact that they are not closed over the rational --- numbers, we must promote standard Haskell math functions from operations --- on 'Real', 'Integral', and 'Fractional' numbers into functions that operate --- on two 'Number' values and return a temporarily-indeterminate 'SomeNumber' --- value. At the callsite, we can then unwrap the 'SomeNumber' and handle the --- specific cases. --- --- Promote a function on 'Real' values into one operating on 'Number's. --- You pass things like @+@ and @-@ here. -liftReal :: (forall n . Real n => n -> n -> n) - -> (Number a -> Number b -> SomeNumber) -liftReal f = liftIntegralFrac f f - --- | Promote two functions, one on 'Integral' and one on 'Fractional' and 'Real' values, --- to operate on 'Numbers'. Examples of this: 'mod' and 'mod'', 'div' and '/'. -liftIntegralFrac :: (forall n . Integral n => n -> n -> n) - -> (forall f . (Fractional f, Real f) => f -> f -> f) - -> (Number a -> Number b -> SomeNumber) -liftIntegralFrac f _ (Integer i) (Integer j) = whole (f i j) -liftIntegralFrac _ g (Integer i) (Ratio j) = ratio (g (toRational i) j) -liftIntegralFrac _ g (Integer i) (Decimal j) = decim (g (fromIntegral i) j) -liftIntegralFrac _ g (Ratio i) (Ratio j) = ratio (g i j) -liftIntegralFrac _ g (Ratio i) (Integer j) = ratio (g i (fromIntegral j)) -liftIntegralFrac _ g (Ratio i) (Decimal j) = decim (g (fromRational i) j) -liftIntegralFrac _ g (Decimal i) (Integer j) = decim (g i (fromIntegral j)) -liftIntegralFrac _ g (Decimal i) (Ratio j) = decim (g i (fromRational j)) -liftIntegralFrac _ g (Decimal i) (Decimal j) = decim (g i j) - --- | Exponential behavior is too hard to generalize, so here's a manually implemented version. --- TODO: Given a 'Ratio' raised to some 'Integer', we could check to see if it's an integer --- and round it before the exponentiation, giving back a 'Integer'. -liftedExponent :: Number a -> Number b -> SomeNumber -liftedExponent (Integer i) (Integer j) = whole (i ^ j) -liftedExponent (Ratio i) (Integer j) = ratio (i ^^ j) -liftedExponent i j = decim (fromFloatDigits (munge i ** munge j)) - where munge = (toRealFloat . toScientific) :: Number a -> Double - -liftedFloorDiv :: Number a -> Number b -> SomeNumber -liftedFloorDiv (Integer i) (Integer j) = whole (i `div` j) -liftedFloorDiv i j = decim (fromIntegral @Prelude.Integer (floor (fromFloatDigits (munge i / munge j)))) - where munge = (toRealFloat . toScientific) :: Number a -> Double diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs deleted file mode 100644 index fc547c9227..0000000000 --- a/src/Data/Abstract/Package.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -module Data.Abstract.Package - ( Package (..) - , PackageInfo (..) - , PackageName - , Data.Abstract.Package.fromModules - ) where - -import Analysis.Name -import Data.Abstract.Module -import Data.Abstract.ModuleTable as ModuleTable -import qualified Data.Map as Map - -type PackageName = Name - --- | Metadata for a package (name and version). -data PackageInfo = PackageInfo - { packageName :: PackageName - , packageResolutions :: Map.Map FilePath FilePath - } - deriving (Eq, Ord, Show) - --- | A package represents the unit of dependency, i.e. something which can depend upon, or be depended upon by, other packages. Packages have modules and may have entry points from which evaluation can proceed. -data Package term = Package - { packageInfo :: PackageInfo - , packageModules :: ModuleTable (Module term) - } - deriving (Eq, Functor, Ord, Show) - -fromModules :: PackageName -> [Module term] -> Map.Map FilePath FilePath -> Package term -fromModules name modules resolutions = Package (PackageInfo name resolutions) (ModuleTable.fromModules modules) diff --git a/src/Data/Abstract/Path.hs b/src/Data/Abstract/Path.hs deleted file mode 100644 index 1370ceb239..0000000000 --- a/src/Data/Abstract/Path.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Data.Abstract.Path - ( dropRelativePrefix - , joinPaths - , stripQuotes - ) where - -import Data.Text (Text) -import qualified Data.Text as T -import qualified System.Path as Path -import System.Path.PartClass (FileDir(..)) - --- | Join two paths a and b. Handles walking up relative directories in b. e.g. --- --- joinPaths "a/b" "../c" == "a/c" --- joinPaths "a/b" "./c" == "a/b/c" --- --- Walking beyond the beginning of a just stops when you get to the root of a. -joinPaths :: FileDir fd => Path.AbsRelDir -> Path.Rel fd -> Path.AbsRel fd -joinPaths = runJP $ switchFileDir (JP joinFilePaths) (JP joinDirPaths) (JP joinFDPaths) - -newtype JP fd = JP {runJP :: Path.AbsRelDir -> Path.Rel fd -> Path.AbsRel fd } - -joinDirPaths :: Path.AbsRelDir -> Path.RelDir -> Path.AbsRelDir -joinDirPaths x y = result isAbs - where - (isAbs, rels, _) = Path.splitPath (Path.normalise $ x Path. y) - (_, fRel) = foldr go (0, Path.currentDir) rels - go :: Path.RelDir -> (Integer, Path.RelDir) -> (Integer, Path.RelDir) - go rel (i, r) - | rel == Path.rel ".." = (i + 1, r) - | i == 0 = (0, rel Path. r) - | otherwise = (i - 1, r) - result True = Path.toAbsRel $ Path.rootDir Path. fRel - result False = Path.toAbsRel $ fRel - - -joinFilePaths :: Path.AbsRelDir -> Path.RelFile -> Path.AbsRelFile -joinFilePaths x y = let (d, f) = Path.splitFileName y in joinDirPaths x d Path. f - -joinFDPaths :: Path.AbsRelDir -> Path.RelFileDir -> Path.AbsRelFileDir -joinFDPaths x = Path.toFileDir . joinDirPaths x . Path.dirFromFileDir - - -stripQuotes :: Text -> Text -stripQuotes = T.dropAround (`elem` ("\'\"" :: String)) - -dropRelativePrefix :: Text -> Text -dropRelativePrefix = T.dropWhile (== '/') . T.dropWhile (== '.') diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs deleted file mode 100644 index 53c9a223c2..0000000000 --- a/src/Data/Abstract/ScopeGraph.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Data.Abstract.ScopeGraph - ( module X - ) where - -import Data.ScopeGraph as X diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs deleted file mode 100644 index b45d08284b..0000000000 --- a/src/Data/Abstract/Value/Abstract.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Abstract.Value.Abstract -( Abstract (..) -, runFunction -, runBoolean -, runWhile -) where - -import Control.Abstract as Abstract -import Control.Algebra -import Data.Abstract.BaseError -import Data.Abstract.Evaluatable -import Data.Foldable -import qualified Data.Map.Strict as Map - -data Abstract = Abstract - deriving (Eq, Ord, Show) - - -instance ( Has (Allocator address) sig m - , Has (Deref Abstract) sig m - , Has (Error (Return Abstract)) sig m - , Has Fresh sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State Span) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError (EvalError term address Abstract))) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Resumable (BaseError (AddressError address Abstract))) sig m - , Has (State (Heap address address Abstract)) sig m - , Declarations term - , Ord address - , Show address - , Algebra sig m - ) - => Algebra (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract m) where - alg (R other) = FunctionC . alg . R . handleCoercible $ other - alg (L op) = runEvaluator $ do - eval <- Evaluator . FunctionC $ ask - case op of - Function _ params body scope k -> do - currentScope' <- currentScope - currentFrame' <- currentFrame - let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame') - frame <- newFrame scope frameLinks - res <- withScopeAndFrame frame $ do - for_ params $ \param -> do - slot <- lookupSlot (Declaration param) - assign slot Abstract - catchReturn (Evaluator (eval body)) - Evaluator (k res) - BuiltIn _ _ k -> Evaluator (k Abstract) - Bind _ _ k -> Evaluator (k Abstract) - Call _ _ k -> Evaluator (k Abstract) - - -instance (Algebra sig m, Alternative m) => Algebra (Boolean Abstract :+: sig) (BooleanC Abstract m) where - alg (L (Boolean _ k)) = k Abstract - alg (L (AsBool _ k)) = k True <|> k False - alg (R other) = BooleanC . alg . handleCoercible $ other - - -instance ( Has (Abstract.Boolean Abstract) sig m - , Algebra sig m - , Alternative m - ) - => Algebra (While Abstract :+: sig) (WhileC Abstract m) where - alg (R other) = WhileC . alg . handleCoercible $ other - alg (L (Abstract.While cond body k)) = do - cond' <- cond - ifthenelse cond' (body *> empty) (k Abstract) - -instance Algebra sig m - => Algebra (Unit Abstract :+: sig) (UnitC Abstract m) where - alg (R other) = UnitC . alg . handleCoercible $ other - alg (L (Abstract.Unit k)) = k Abstract - -instance Algebra sig m - => Algebra (Abstract.String Abstract :+: sig) (StringC Abstract m) where - alg (R other) = StringC . alg . handleCoercible $ other - alg (L op) = case op of - Abstract.String _ k -> k Abstract - AsString _ k -> k "" - -instance Algebra sig m - => Algebra (Numeric Abstract :+: sig) (NumericC Abstract m) where - alg (R other) = NumericC . alg . handleCoercible $ other - alg (L op) = case op of - Integer _ k -> k Abstract - Float _ k -> k Abstract - Rational _ k -> k Abstract - LiftNumeric _ _ k -> k Abstract - LiftNumeric2 _ _ _ k -> k Abstract - -instance Algebra sig m - => Algebra (Bitwise Abstract :+: sig) (BitwiseC Abstract m) where - alg (R other) = BitwiseC . alg . handleCoercible $ other - alg (L op) = case op of - CastToInteger _ k -> k Abstract - LiftBitwise _ _ k -> k Abstract - LiftBitwise2 _ _ _ k -> k Abstract - UnsignedRShift _ _ k -> k Abstract - -instance Algebra sig m - => Algebra (Object address Abstract :+: sig) (ObjectC address Abstract m) where - alg (R other) = ObjectC . alg . handleCoercible $ other - alg (L op) = case op of - Object _ k -> k Abstract - ScopedEnvironment _ k -> k Nothing - Klass _ _ k -> k Abstract - -instance Algebra sig m - => Algebra (Array Abstract :+: sig) (ArrayC Abstract m) where - alg (R other) = ArrayC . alg . handleCoercible $ other - alg (L op) = case op of - Array _ k -> k Abstract - AsArray _ k -> k [] - -instance Algebra sig m - => Algebra (Hash Abstract :+: sig) (HashC Abstract m) where - alg (R other) = HashC . alg . handleCoercible $ other - alg (L op) = case op of - Hash _ k -> k Abstract - KvPair _ _ k -> k Abstract - - -instance Ord address => ValueRoots address Abstract where - valueRoots = mempty - -instance AbstractHole Abstract where - hole = Abstract - -instance AbstractIntro Abstract where - null = Abstract - -instance Applicative m => AbstractValue term address Abstract m where - tuple _ = pure Abstract - - namespace _ _ = pure Abstract - - asPair _ = pure (Abstract, Abstract) - - index _ _ = pure Abstract - - liftComparison _ _ _ = pure Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs deleted file mode 100644 index 2382ca2fc1..0000000000 --- a/src/Data/Abstract/Value/Concrete.hs +++ /dev/null @@ -1,434 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Abstract.Value.Concrete - ( Value (..) - , ValueError (..) - , runValueError - , runValueErrorWith - ) where - -import Control.Carrier.Resumable.Either (SomeError) -import qualified Control.Carrier.Resumable.Either as Either -import qualified Control.Carrier.Resumable.Resume as With -import Control.Exception (ArithException) -import Data.Bits (shiftR) -import Data.Foldable -import Data.Function -import Data.Functor -import Data.Functor.Classes -import Data.List (genericIndex, genericLength) -import qualified Data.Map.Strict as Map -import Data.Scientific.Exts -import Data.Semilattice.Lower -import Data.Text (Text, pack) -import Data.Word - -import Analysis.Name -import Control.Abstract hiding - (Array (..), Boolean (..), Function (..), Hash (..), Numeric (..), Object (..), String (..), Unit (..), While (..)) -import qualified Control.Abstract as Abstract -import Control.Algebra -import Control.Effect.Interpose -import Data.Abstract.BaseError -import Data.Abstract.Evaluatable (Declarations, EvalError (..), UnspecializedError (..), __self) -import Data.Abstract.FreeVariables -import qualified Data.Abstract.Number as Number - - -data Value term address - -- TODO: Split Closure up into a separate data type. Scope Frame - = Closure PackageInfo ModuleInfo (Maybe Name) (Maybe (Value term address)) [Name] (Either BuiltIn term) address address - | Unit - | Boolean Bool - | Integer (Number.Number Integer) - | Rational (Number.Number Rational) - | Float (Number.Number Scientific) - | String Text - | Tuple [Value term address] - | Array [Value term address] - | Class Declaration [Value term address] address - | Object address - | Namespace Name address - | KVPair (Value term address) (Value term address) - | Hash [Value term address] - | Null - | Hole - deriving (Eq, Ord, Show) - - -instance ValueRoots address (Value term address) where - valueRoots _ = lowerBound - - -instance ( FreeVariables term - , Has (Allocator address) sig m - , Has (Deref (Value term address)) sig m - , Has Fresh sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader PackageInfo) sig m - , Has (Reader Span) sig m - , Has (State Span) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError (AddressError address (Value term address)))) sig m - , Has (Resumable (BaseError (EvalError term address (Value term address)))) sig m - , Has (Resumable (BaseError (ValueError term address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (State (Heap address address (Value term address))) sig m - , Has (Error (Return (Value term address))) sig m - , Declarations term - , Has Trace sig m - , Ord address - , Algebra sig m - , Show address - , Show term - ) - => Algebra (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) m) where - alg (R other) = FunctionC . alg . R . handleCoercible $ other - alg (L op) = runEvaluator $ do - eval <- Evaluator . FunctionC $ ask - let closure maybeName params body scope = do - packageInfo <- currentPackage - moduleInfo <- currentModule - Closure packageInfo moduleInfo maybeName Nothing params body scope <$> currentFrame - - case op of - Abstract.Function name params body scope k -> do - val <- closure (Just name) params (Right body) scope - Evaluator (k val) - Abstract.BuiltIn associatedScope builtIn k -> do - val <- closure Nothing [] (Left builtIn) associatedScope - Evaluator (k val) - Abstract.Bind obj@Object{} (Closure packageInfo moduleInfo name _ names body scope parentFrame) k -> - Evaluator (k (Closure packageInfo moduleInfo name (Just obj) names body scope parentFrame)) - Abstract.Bind _ value k -> Evaluator (k value) - Abstract.Call op params k -> do - boxed <- case op of - Closure _ _ _ _ _ (Left Print) _ _ -> traverse (trace . show) params $> Unit - Closure _ _ _ _ _ (Left Show) _ _ -> pure . String . pack $ show params - Closure packageInfo moduleInfo _ maybeSelf names (Right body) associatedScope parentFrame -> do - -- Evaluate the bindings and body with the closure’s package/module info in scope in order to - -- charge them to the closure's origin. - withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do - parentScope <- scopeLookup parentFrame - let frameEdges = Map.singleton Lexical (Map.singleton parentScope parentFrame) - frameAddress <- newFrame associatedScope frameEdges - withScopeAndFrame frameAddress $ do - case maybeSelf of - Just object -> do - maybeSlot <- maybeLookupDeclaration (Declaration __self) - maybe (pure ()) (`assign` object) maybeSlot - Nothing -> pure () - for_ (zip names params) $ \(name, param) -> do - slot <- lookupSlot (Declaration name) - assign slot param - catchReturn (Evaluator (eval body)) - _ -> throwValueError (CallError op) - Evaluator (k boxed) - -instance ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (ValueError term address))) sig m - , Algebra sig m - , Monad m - ) - => Algebra (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where - alg (R other) = BooleanC . alg . handleCoercible $ other - alg (L op) = case op of - Abstract.Boolean b k -> k $! Boolean b - Abstract.AsBool (Boolean b) k -> k b - Abstract.AsBool other k -> throwBaseError (BoolError other) >>= k - -instance ( Algebra sig m - , Has (Abstract.Boolean (Value term address)) sig m - , Has (Error (LoopControl (Value term address))) sig m - , Has (Interpose (Resumable (BaseError (UnspecializedError address (Value term address))))) sig m - ) - => Algebra (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where - alg (R other) = WhileC . alg . handleCoercible $ other - alg (L (Abstract.While cond body k)) = do - - let loop x = catchError x $ \case - Break value -> pure value - Abort -> pure Unit - -- FIXME: Figure out how to deal with this. Ruby treats this as the result - -- of the current block iteration, while PHP specifies a breakout level - -- and TypeScript appears to take a label. - Continue _ -> loop x - - interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (loop (do - cond' <- cond - - -- `interpose` is used to handle 'UnspecializedError's and abort out of the - -- loop, otherwise under concrete semantics we run the risk of the - -- conditional always being true and getting stuck in an infinite loop. - ifthenelse cond' (body *> throwError (Continue @(Value term address) Unit)) (pure Unit))) - (\case - Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) - Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) >>= k - - - - -- Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do cond' <- Evaluator (runWhileC cond) - - -- -- `interpose` is used to handle 'UnspecializedError's and abort out of the - -- -- loop, otherwise under concrete semantics we run the risk of the - -- -- conditional always being true and getting stuck in an infinite loop. - - -- ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit)))) - -- ( - -- >>= runWhileC . k) - -- where - -- loop x = catchLoopControl (fix x) $ \case - -- Break value -> pure value - -- Abort -> pure Unit - -- -- FIXME: Figure out how to deal with this. Ruby treats this as the result - -- -- of the current block iteration, while PHP specifies a breakout level - -- -- and TypeScript appears to take a label. - -- Continue _ -> loop x - - -- case op of - -- Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do - -- cond' <- Evaluator (runWhileC cond) - - -- -- `interpose` is used to handle 'UnspecializedError's and abort out of the - -- -- loop, otherwise under concrete semantics we run the risk of the - -- -- conditional always being true and getting stuck in an infinite loop. - - -- ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit) - -- case _ of - -- Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) >>= k - -- Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) >>= k - - -instance Algebra sig m - => Algebra (Abstract.Unit (Value term address) :+: sig) (UnitC (Value term address) m) where - alg (R other) = UnitC . alg . handleCoercible $ other - alg (L (Abstract.Unit k )) = k Unit - -instance ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (ValueError term address))) sig m - , Algebra sig m - , Monad m - ) - => Algebra (Abstract.String (Value term address) :+: sig) (StringC (Value term address) m) where - alg (R other) = StringC . alg . handleCoercible $ other - alg (L op) = case op of - Abstract.String t k -> k (String t) - Abstract.AsString (String t) k -> k t - Abstract.AsString other k -> throwBaseError (StringError other) >>= k - -instance ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (ValueError term address))) sig m - , Algebra sig m - , Monad m - ) - => Algebra (Abstract.Numeric (Value term address) :+: sig) (NumericC (Value term address) m) where - alg (R other) = NumericC . alg . handleCoercible $ other - alg (L op) = case op of - Abstract.Integer t k -> k (Integer (Number.Integer t)) - Abstract.Float t k -> k (Float (Number.Decimal t)) - Abstract.Rational t k -> k (Rational (Number.Ratio t)) - Abstract.LiftNumeric f arg k -> k =<< case arg of - Integer (Number.Integer i) -> pure $ Integer (Number.Integer (runNumericFunction f i)) - Float (Number.Decimal d) -> pure $ Float (Number.Decimal (runNumericFunction f d)) - Rational (Number.Ratio r) -> pure $ Rational (Number.Ratio (runNumericFunction f r)) - other -> throwBaseError (NumericError other) - Abstract.LiftNumeric2 f left right k -> k =<< case (left, right) of - (Integer i, Integer j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize - (Integer i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize - (Integer i, Float j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize - (Rational i, Integer j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize - (Rational i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize - (Rational i, Float j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize - (Float i, Integer j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize - (Float i, Rational j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize - (Float i, Float j) -> attemptUnsafeArithmetic (runNumeric2Function f i j) & specialize - _ -> throwBaseError (Numeric2Error left right) - --- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor -specialize :: ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (ValueError term address))) sig m - ) - => Either ArithException Number.SomeNumber - -> m (Value term address) -specialize (Left exc) = throwBaseError (ArithmeticError exc) -specialize (Right (Number.SomeNumber (Number.Integer t))) = pure (Integer (Number.Integer t)) -specialize (Right (Number.SomeNumber (Number.Decimal t))) = pure (Float (Number.Decimal t)) -specialize (Right (Number.SomeNumber (Number.Ratio t))) = pure (Rational (Number.Ratio t)) - - -instance ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (ValueError term address))) sig m - , Algebra sig m - , Monad m - ) - => Algebra (Abstract.Bitwise (Value term address) :+: sig) (BitwiseC (Value term address) m) where - alg (R other) = BitwiseC . alg . handleCoercible $ other - alg (L op) = case op of - CastToInteger (Integer (Number.Integer i)) k -> k (Integer (Number.Integer i)) - CastToInteger (Float (Number.Decimal i)) k -> k (Integer (Number.Integer (coefficient (normalize i)))) - CastToInteger i k -> throwBaseError (NumericError i) >>= k - LiftBitwise operator (Integer (Number.Integer i)) k -> k . Integer . Number.Integer . runBitwiseFunction operator $ i - LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= k - LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> k . Integer . Number.Integer $ runBitwise2Function operator i j - LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= k - UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j) - UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= k - -ourShift :: Word64 -> Int -> Integer -ourShift a b = toInteger (shiftR a b) - - -instance Algebra sig m => Algebra (Abstract.Object address (Value term address) :+: sig) (ObjectC address (Value term address) m) where - alg (R other) = ObjectC . alg . handleCoercible $ other - alg (L op) = case op of - Abstract.Object address k -> k (Object address) - Abstract.ScopedEnvironment (Object address) k -> k (Just address) - Abstract.ScopedEnvironment (Class _ _ address) k -> k (Just address) - Abstract.ScopedEnvironment (Namespace _ address) k -> k (Just address) - Abstract.ScopedEnvironment _ k -> k Nothing - Abstract.Klass n frame k -> k (Class n mempty frame) - -instance ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (ValueError term address))) sig m - , Algebra sig m - , Monad m - ) - => Algebra (Abstract.Array (Value term address) :+: sig) (ArrayC (Value term address) m) where - alg (R other) = ArrayC . alg . handleCoercible $ other - alg (L op) = case op of - Abstract.Array t k -> k (Array t) - Abstract.AsArray (Array addresses) k -> k addresses - Abstract.AsArray val k -> throwBaseError (ArrayError val) >>= k - -instance ( Algebra sig m ) => Algebra (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where - alg (R other) = HashC . alg . handleCoercible $ other - alg (L op) = case op of - Abstract.Hash t k -> k ((Hash . map (uncurry KVPair)) t) - Abstract.KvPair t v k -> k (KVPair t v) - - -instance AbstractHole (Value term address) where - hole = Hole - -instance (Show address, Show term) => AbstractIntro (Value term address) where - null = Null - --- | Construct a 'Value' wrapping the value arguments (if any). -instance ( Has (Abstract.Boolean (Value term address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (ValueError term address))) sig m - , Show address - , Show term - , Algebra sig m - ) - => AbstractValue term address (Value term address) m where - asPair val - | KVPair k v <- val = pure (k, v) - | otherwise = throwValueError $ KeyValueError val - - tuple = pure . Tuple - - namespace name = pure . Namespace name - - index = go where - tryIdx list ii - | ii > genericLength list = throwValueError (BoundsError list ii) - | otherwise = pure (genericIndex list ii) - go arr idx - | (Array arr, Integer (Number.Integer i)) <- (arr, idx) = tryIdx arr i - | (Tuple tup, Integer (Number.Integer i)) <- (arr, idx) = tryIdx tup i - | otherwise = throwValueError (IndexError arr idx) - - liftComparison comparator left right - | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = go i j - | (Integer (Number.Integer i), Float (Number.Decimal j)) <- pair = go (fromIntegral i) j - | (Float (Number.Decimal i), Integer (Number.Integer j)) <- pair = go i (fromIntegral j) - | (Float (Number.Decimal i), Float (Number.Decimal j)) <- pair = go i j - | (String i, String j) <- pair = go i j - | (Boolean i, Boolean j) <- pair = go i j - | (Unit, Unit) <- pair = boolean True - | otherwise = throwValueError (ComparisonError left right) - where - -- Explicit type signature is necessary here because we're passing all sorts of things - -- to these comparison functions. - go :: Ord a => a -> a -> Evaluator term address (Value term address) m (Value term address) - go l r = case comparator of - Concrete f -> boolean (f l r) - Generalized -> pure $ Integer (Number.Integer (orderingToInt (compare l r))) - - -- Map from [LT, EQ, GT] to [-1, 0, 1] - orderingToInt :: Ordering -> Prelude.Integer - orderingToInt = toInteger . pred . fromEnum - - pair = (left, right) - --- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance. -data ValueError term address resume where - StringError :: Value term address -> ValueError term address Text - BoolError :: Value term address -> ValueError term address Bool - IndexError :: Value term address -> Value term address -> ValueError term address (Value term address) - CallError :: Value term address -> ValueError term address (Value term address) - NumericError :: Value term address -> ValueError term address (Value term address) - Numeric2Error :: Value term address -> Value term address -> ValueError term address (Value term address) - ComparisonError :: Value term address -> Value term address -> ValueError term address (Value term address) - BitwiseError :: Value term address -> ValueError term address (Value term address) - Bitwise2Error :: Value term address -> Value term address -> ValueError term address (Value term address) - KeyValueError :: Value term address -> ValueError term address (Value term address, Value term address) - ArrayError :: Value term address -> ValueError term address [Value term address] - -- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching. - ArithmeticError :: ArithException -> ValueError term address (Value term address) - -- Out-of-bounds error - BoundsError :: [Value term address] -> Prelude.Integer -> ValueError term address (Value term address) - -instance (Eq address, Eq term) => Eq1 (ValueError term address) where - liftEq _ (StringError a) (StringError b) = a == b - liftEq _ (CallError a) (CallError b) = a == b - liftEq _ (BoolError a) (BoolError c) = a == c - liftEq _ (IndexError a b) (IndexError c d) = (a == c) && (b == d) - liftEq _ (Numeric2Error a b) (Numeric2Error c d) = (a == c) && (b == d) - liftEq _ (ComparisonError a b) (ComparisonError c d) = (a == c) && (b == d) - liftEq _ (Bitwise2Error a b) (Bitwise2Error c d) = (a == c) && (b == d) - liftEq _ (BitwiseError a) (BitwiseError b) = a == b - liftEq _ (KeyValueError a) (KeyValueError b) = a == b - liftEq _ (BoundsError a b) (BoundsError c d) = (a == c) && (b == d) - liftEq _ _ _ = False - -deriving instance (Show address, Show term) => Show (ValueError term address resume) -instance (Show address, Show term) => Show1 (ValueError term address) where - liftShowsPrec _ _ = showsPrec - -runValueError :: Evaluator term address (Value term address) (Either.ResumableC (BaseError (ValueError term address)) m) a - -> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a) -runValueError = Evaluator . Either.runResumable . runEvaluator - -runValueErrorWith :: (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume) - -> Evaluator term address (Value term address) (With.ResumableC (BaseError (ValueError term address)) m) a - -> Evaluator term address (Value term address) m a -runValueErrorWith f = Evaluator . With.runResumable (runEvaluator . f) . runEvaluator - -throwValueError :: ( Has (Resumable (BaseError (ValueError term address))) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - ) - => ValueError term address resume - -> Evaluator term address (Value term address) m resume -throwValueError = throwBaseError diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs deleted file mode 100644 index 73a828331d..0000000000 --- a/src/Data/Abstract/Value/Type.hs +++ /dev/null @@ -1,442 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Abstract.Value.Type - ( Type (..) - , TypeError (..) - , TypeMap - , runTypes - , runTypesWith - , unify - , runFunction - , runBoolean - , runWhile - ) where - -import Control.Algebra -import Control.Carrier.Resumable.Either (SomeError) -import qualified Control.Carrier.Resumable.Either as Either -import qualified Control.Carrier.Resumable.Resume as With -import Control.Carrier.State.Strict -import Control.Monad -import Data.Functor -import Data.Functor.Classes -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import qualified Data.Map as Map - -import Control.Abstract hiding - (Array (..), Boolean (..), Function (..), Hash (..), Numeric (..), Object (..), String (..), Unit (..), While (..), Void) -import qualified Control.Abstract as Abstract -import Data.Abstract.BaseError -import Data.Abstract.Evaluatable -import Data.Semigroup.Foldable (foldMap1) - -type TName = Int - --- | A datatype representing primitive types and combinations thereof. -data Type - = Int -- ^ Primitive int type. - | Bool -- ^ Primitive boolean type. - | String -- ^ Primitive string type. - | Unit -- ^ The unit type. - | Float -- ^ Floating-point type. - | Rational -- ^ Rational type. - | Type :-> Type -- ^ Binary function types. - | Var TName -- ^ A type variable. - | Type :* Type -- ^ Binary products. - | Type :+ Type -- ^ Binary sums. - | Void -- ^ Uninhabited void type. - | Array Type -- ^ Arrays. - | Hash [(Type, Type)] -- ^ Heterogenous key-value maps. - | Object -- ^ Objects. Once we have some notion of inheritance we'll need to store a superclass. - | Null -- ^ The null type. Unlike 'Unit', this unifies with any other type. - | Hole -- ^ The hole type. - deriving (Eq, Ord, Show) - -infixl 6 :+ -infixl 7 :* -infixr 0 :-> - -newtype Product = Product { getProduct :: Type } - -instance Semigroup Product where - Product a <> Product b = Product (a :* b) - -instance Monoid Product where - mempty = Product Unit - mappend = (<>) - -oneOrMoreProduct :: NonEmpty Type -> Type -oneOrMoreProduct = getProduct . foldMap1 Product - -zeroOrMoreProduct :: [Type] -> Type -zeroOrMoreProduct = maybe Unit oneOrMoreProduct . nonEmpty - --- TODO: À la carte representation of types. - --- | Errors representing failures in typechecking. Note that we should in general constrain allowable types by 'unify'ing, and thus throwing 'UnificationError's when constraints aren’t met, in order to allow uniform resumption with one or the other parameter type. -data TypeError resume where - UnificationError :: Type -> Type -> TypeError Type - InfiniteType :: Type -> Type -> TypeError Type - -deriving instance Eq (TypeError resume) -deriving instance Ord (TypeError resume) -deriving instance Show (TypeError resume) - -instance Eq1 TypeError where - liftEq _ (UnificationError a1 b1) (UnificationError a2 b2) = a1 == a2 && b1 == b2 - liftEq _ (InfiniteType a1 b1) (InfiniteType a2 b2) = a1 == a2 && b1 == b2 - liftEq _ _ _ = False - -instance Ord1 TypeError where - liftCompare _ (UnificationError a1 b1) (UnificationError a2 b2) = compare a1 a2 <> compare b1 b2 - liftCompare _ (InfiniteType a1 b1) (InfiniteType a2 b2) = compare a1 a2 <> compare b1 b2 - liftCompare _ (InfiniteType _ _) (UnificationError _ _) = LT - liftCompare _ (UnificationError _ _) (InfiniteType _ _) = GT - -instance Show1 TypeError where liftShowsPrec _ _ = showsPrec - -runTypeError :: Evaluator term address value (Either.ResumableC (BaseError TypeError) m) a - -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a) -runTypeError = raiseHandler Either.runResumable - -runTypeErrorWith :: (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume) - -> Evaluator term address value (With.ResumableC (BaseError TypeError) m) a - -> Evaluator term address value m a -runTypeErrorWith f = raiseHandler $ With.runResumable (runEvaluator . f) - - -throwTypeError :: ( Has (Resumable (BaseError TypeError)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - ) - => TypeError resume - -> m resume -throwTypeError = throwBaseError - -runTypeMap :: Algebra sig m - => Evaluator term address Type (StateC TypeMap m) a - -> Evaluator term address Type m a -runTypeMap = raiseHandler $ fmap snd . runState emptyTypeMap - -runTypes :: Algebra sig m - => Evaluator term address Type (Either.ResumableC (BaseError TypeError) - (StateC TypeMap m)) a - -> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a) -runTypes = runTypeMap . runTypeError - -runTypesWith :: Algebra sig m - => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap m) resume) - -> Evaluator term address Type (With.ResumableC (BaseError TypeError) - (StateC TypeMap - m)) a - -> Evaluator term address Type m a -runTypesWith with = runTypeMap . runTypeErrorWith with - --- TODO: change my name? -newtype TypeMap = TypeMap { unTypeMap :: Map.Map TName Type } - -emptyTypeMap :: TypeMap -emptyTypeMap = TypeMap Map.empty - -modifyTypeMap :: Has (State TypeMap) sig m - => (Map.Map TName Type -> Map.Map TName Type) - -> m () -modifyTypeMap f = modify (TypeMap . f . unTypeMap) - --- | Prunes substituted type variables -prune :: Has (State TypeMap) sig m - => Type - -> m Type -prune (Var id) = gets (Map.lookup id . unTypeMap) >>= \case - Just ty -> do - pruned <- prune ty - modifyTypeMap (Map.insert id pruned) - pure pruned - Nothing -> pure (Var id) -prune ty = pure ty - --- | Checks whether a type variable name occurs within another type. This --- function is used in 'substitute' to prevent unification of infinite types -occur :: Has (State TypeMap) sig m - => TName - -> Type - -> m Bool -occur id = prune >=> \case - Int -> pure False - Bool -> pure False - String -> pure False - Unit -> pure False - Float -> pure False - Rational -> pure False - Void -> pure False - Object -> pure False - Null -> pure False - Hole -> pure False - a :-> b -> eitherM (occur id) (a, b) - a :* b -> eitherM (occur id) (a, b) - a :+ b -> eitherM (occur id) (a, b) - Array ty -> occur id ty - Hash kvs -> or <$> traverse (eitherM (occur id)) kvs - Var vid -> pure (vid == id) - where - eitherM :: Applicative m => (a -> m Bool) -> (a, a) -> m Bool - eitherM f (a, b) = (||) <$> f a <*> f b - --- | Substitutes a type variable name for another type -substitute :: ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError TypeError)) sig m - , Has (State TypeMap) sig m - ) - => TName - -> Type - -> m Type -substitute id ty = do - infiniteType <- occur id ty - ty <- if infiniteType - then throwTypeError (InfiniteType (Var id) ty) - else pure ty - modifyTypeMap (Map.insert id ty) - pure ty - --- | Unify two 'Type's. -unify :: ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError TypeError)) sig m - , Has (State TypeMap) sig m - ) - => Type - -> Type - -> m Type -unify a b = do - a' <- prune a - b' <- prune b - case (a', b') of - (a1 :-> b1, a2 :-> b2) -> (:->) <$> unify a1 a2 <*> unify b1 b2 - (a, Null) -> pure a - (Null, b) -> pure b - (Var id, ty) -> substitute id ty - (ty, Var id) -> substitute id ty - (Array t1, Array t2) -> Array <$> unify t1 t2 - -- FIXME: unifying with sums should distribute nondeterministically. - -- FIXME: ordering shouldn’t be significant for undiscriminated sums. - (a1 :+ b1, a2 :+ b2) -> (:+) <$> unify a1 a2 <*> unify b1 b2 - (a1 :* b1, a2 :* b2) -> (:*) <$> unify a1 a2 <*> unify b1 b2 - (t1, t2) | t1 == t2 -> pure t2 - _ -> throwTypeError (UnificationError a b) - -instance Ord address => ValueRoots address Type where - valueRoots _ = mempty - - -instance ( Has (Allocator address) sig m - , Has (Deref Type) sig m - , Has (Error (Return Type)) sig m - , Has Fresh sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (State Span) sig m - , Has (Resumable (BaseError (EvalError term address Type))) sig m - , Has (Resumable (BaseError TypeError)) sig m - , Has (Resumable (BaseError (AddressError address Type))) sig m - , Has (State (Heap address address Type)) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (State TypeMap) sig m - , Declarations term - , Ord address - , Show address - , Algebra sig m - ) - => Algebra (Abstract.Function term address Type :+: sig) (FunctionC term address Type m) where - alg (R other) = FunctionC (alg (R (handleCoercible other))) - alg (L op) = runEvaluator $ do - eval <- Evaluator . FunctionC $ ask - case op of - Abstract.Function _ params body scope k -> do - currentScope' <- currentScope - currentFrame' <- currentFrame - let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame') - frame <- newFrame scope frameLinks - res <- withScopeAndFrame frame $ do - tvars <- foldr (\ param rest -> do - tvar <- Var <$> fresh - slot <- lookupSlot (Declaration param) - assign slot tvar - (tvar :) <$> rest) (pure []) params - -- TODO: We may still want to represent this as a closure and not a function type - (zeroOrMoreProduct tvars :->) <$> catchReturn (Evaluator (eval body)) - Evaluator (k res) - - Abstract.BuiltIn _ Print k -> Evaluator $ k (String :-> Unit) - Abstract.BuiltIn _ Show k -> Evaluator $ k (Object :-> String) - Abstract.Bind _ value k -> Evaluator $ k value - Abstract.Call op paramTypes k -> do - tvar <- fresh - let needed = zeroOrMoreProduct paramTypes :-> Var tvar - unified <- op `unify` needed - boxed <- case unified of - _ :-> ret -> pure ret - actual -> throwTypeError (UnificationError needed actual) - Evaluator (k boxed) - - - -instance ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError TypeError)) sig m - , Has (State TypeMap) sig m - , Algebra sig m - , Alternative m - ) - => Algebra (Abstract.Boolean Type :+: sig) (BooleanC Type m) where - alg (R other) = BooleanC . alg . handleCoercible $ other - alg (L (Abstract.Boolean _ k)) = k Bool - alg (L (Abstract.AsBool t k)) = unify t Bool *> (k True <|> k False) - - - -instance ( Has (Abstract.Boolean Type) sig m - , Algebra sig m - , Alternative m - ) - => Algebra (Abstract.While Type :+: sig) (WhileC Type m) where - alg (R other) = WhileC . alg . handleCoercible $ other - alg (L (Abstract.While cond body k)) = do - cond' <- cond - ifthenelse cond' (body *> empty) (k Unit) - - -instance Algebra sig m - => Algebra (Abstract.Unit Type :+: sig) (UnitC Type m) where - alg (R other) = UnitC . alg . handleCoercible $ other - alg (L (Abstract.Unit k)) = k Unit - -instance ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError TypeError)) sig m - , Has (State TypeMap) sig m - , Algebra sig m - , Alternative m - ) - => Algebra (Abstract.String Type :+: sig) (StringC Type m) where - alg (R other) = StringC . alg . handleCoercible $ other - alg (L (Abstract.String _ k)) = k String - alg (L (Abstract.AsString t k)) = unify t String *> k "" - -instance ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError TypeError)) sig m - , Has (State TypeMap) sig m - , Algebra sig m - , Monad m - ) - => Algebra (Abstract.Numeric Type :+: sig) (NumericC Type m) where - alg (R other) = NumericC . alg . handleCoercible $ other - alg (L op) = case op of - Abstract.Integer _ k -> k Int - Abstract.Float _ k -> k Float - Abstract.Rational _ k -> k Rational - Abstract.LiftNumeric _ t k -> unify (Int :+ Float :+ Rational) t >>= k - Abstract.LiftNumeric2 _ left right k -> case (left, right) of - (Float, Int) -> k Float - (Int, Float) -> k Float - _ -> unify left right >>= k - -instance ( Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError TypeError)) sig m - , Has (State TypeMap) sig m - , Algebra sig m - , Monad m - ) - => Algebra (Abstract.Bitwise Type :+: sig) (BitwiseC Type m) where - alg (R other) = BitwiseC . alg . handleCoercible $ other - alg (L op) = case op of - CastToInteger t k -> unify t (Int :+ Float :+ Rational) *> k Int - LiftBitwise _ t k -> unify t Int >>= k - LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= k - UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= k - -instance ( Algebra sig m ) => Algebra (Abstract.Object address Type :+: sig) (ObjectC address Type m) where - alg (R other) = ObjectC . alg . handleCoercible $ other - alg (L op) = case op of - Abstract.Object _ k -> k Object - Abstract.ScopedEnvironment _ k -> k Nothing - Abstract.Klass _ _ k -> k Object - -instance ( Has Fresh sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError TypeError)) sig m - , Has (State TypeMap) sig m - , Algebra sig m - , Monad m - ) - => Algebra (Abstract.Array Type :+: sig) (ArrayC Type m) where - alg (R other) = ArrayC . alg . handleCoercible $ other - alg (L (Abstract.Array fieldTypes k)) = do - var <- fresh - fieldType <- foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes - k (Array fieldType) - alg (L (Abstract.AsArray t k)) = do - field <- fresh - unify t (Array (Var field)) >> k mempty - -instance ( Algebra sig m ) => Algebra (Abstract.Hash Type :+: sig) (HashC Type m) where - alg (R other) = HashC . alg . handleCoercible $ other - alg (L (Abstract.Hash t k)) = k (Hash t) - alg (L (Abstract.KvPair t1 t2 k)) = k (t1 :* t2) - - -instance AbstractHole Type where - hole = Hole - -instance AbstractIntro Type where - null = Null - --- | Discard the value arguments (if any), constructing a 'Type' instead. -instance ( Has Fresh sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError TypeError)) sig m - , Has (State TypeMap) sig m - , Algebra sig m - ) - => AbstractValue term address Type m where - tuple fields = pure $ zeroOrMoreProduct fields - - namespace _ _ = pure Unit - - asPair t = do - t1 <- fresh - t2 <- fresh - unify t (Var t1 :* Var t2) $> (Var t1, Var t2) - - index arr sub = do - _ <- unify sub Int - field <- fresh - _ <- unify (Array (Var field)) arr - pure (Var field) - - liftComparison (Concrete _) left right = case (left, right) of - (Float, Int) -> pure Bool - (Int, Float) -> pure Bool - _ -> unify left right $> Bool - liftComparison Generalized left right = case (left, right) of - (Float, Int) -> pure Int - (Int, Float) -> pure Int - _ -> unify left right $> Bool diff --git a/src/Data/Graph/ControlFlowVertex.hs b/src/Data/Graph/ControlFlowVertex.hs deleted file mode 100644 index 77e916255c..0000000000 --- a/src/Data/Graph/ControlFlowVertex.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Graph.ControlFlowVertex -( ControlFlowVertex (..) -, packageVertex -, moduleVertex -, unknownModuleVertex -, variableVertex -, methodVertex -, functionVertex -, vertexIdentifier -, showSpan -, VertexDeclaration (..) -, toVertex1 -, VertexDeclaration1 (..) -) where - -import Analysis.Name -import Data.Abstract.Declarations -import Data.Abstract.Module (ModuleInfo (..)) -import Data.Abstract.Package (PackageInfo (..)) -import Data.Aeson -import Data.Graph.Algebraic (VertexTag (..)) -import Data.Hashable -import Data.Proxy -import Data.Quieterm (Quieterm (..)) -import Data.Semilattice.Lower -import Data.Sum -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import Data.Term -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics (V1) -import Prelude hiding (span) -import qualified Source.Loc as Loc -import Source.Span -import qualified System.Path as Path - --- | A vertex of representing some node in a control flow graph. -data ControlFlowVertex - = Package Text - | Module Text - | UnknownModule Text - | Variable Text Text Span - | Method Text Text Span - | Function Text Text Span - deriving (Eq, Ord, Show) - -packageVertex :: PackageInfo -> ControlFlowVertex -packageVertex (PackageInfo name _) = Package (formatName name) - -moduleVertex :: ModuleInfo -> ControlFlowVertex -moduleVertex = Module . T.pack . Path.toString . modulePath - -unknownModuleVertex :: ModuleInfo -> ControlFlowVertex -unknownModuleVertex = UnknownModule . T.pack . Path.toString . modulePath - -variableVertex :: Text -> ModuleInfo -> Span -> ControlFlowVertex -variableVertex name ModuleInfo{..} = Variable name (T.pack $ Path.toString modulePath) - -methodVertex :: Text -> ModuleInfo -> Span -> ControlFlowVertex -methodVertex name ModuleInfo{..} = Method name (T.pack $ Path.toString modulePath) - -functionVertex :: Text -> ModuleInfo -> Span -> ControlFlowVertex -functionVertex name ModuleInfo{..} = Function name (T.pack $ Path.toString modulePath) - -vertexIdentifier :: ControlFlowVertex -> Text -vertexIdentifier v = case v of - Package n -> n <> " (" <> vertexToType v <> ")" - Module n -> n <> " (" <> vertexToType v <> ")" - UnknownModule n -> n <> " (" <> vertexToType v <> ")" - Variable n m s -> m <> "::" <> n <> " (" <> vertexToType v <> " " <> showSpan s <> ")" - Method n m s -> m <> "::" <> n <> " (" <> vertexToType v <> " " <> showSpan s <> ")" - Function n m s -> m <> "::" <> n <> " (" <> vertexToType v <> " " <> showSpan s <> ")" - -showSpan :: Span -> Text -showSpan (Span (Pos a b) (Pos c d)) = T.pack $ - "[" <> show a <> ", " <> show b <> "]" - <> " - " - <> "[" <> show c <> ", " <> show d <> "]" - -vertexToType :: ControlFlowVertex -> Text -vertexToType Package{} = "Package" -vertexToType Module{} = "Module" -vertexToType UnknownModule{} = "Unknown Module" -vertexToType Variable{} = "Variable" -vertexToType Method{} = "Method" -vertexToType Function{} = "Function" - - --- Instances - -instance Lower ControlFlowVertex where lowerBound = Package "" -instance VertexTag ControlFlowVertex where uniqueTag = hash . vertexIdentifier - -instance ToJSON ControlFlowVertex where - toJSON v = object [ "name" .= vertexIdentifier v - , "type" .= vertexToType v - , "id" .= show (uniqueTag v) - ] - toEncoding v = pairs $ mconcat [ "name" .= vertexIdentifier v - , "type" .= vertexToType v - , "id" .= show (uniqueTag v) - ] - --- TODO: This is potentially valuable just to get name's out of declarable things. --- Typeclasses to create 'ControlFlowVertex's from 'Term's. Also extracts --- 'Name's for terms with symbolic names like Identifiers and Declarations. - -class VertexDeclaration term where - toVertex - :: ModuleInfo - -> term Loc.Loc - -> Maybe (ControlFlowVertex, Name) - -instance (VertexDeclaration1 f, Declarations1 f) => VertexDeclaration (Term f) where - toVertex info (Term (In a f)) = liftToVertex toVertex a info f - -instance (VertexDeclaration1 f, Declarations1 f) => VertexDeclaration (Quieterm f) where - toVertex info (Quieterm (In a f)) = liftToVertex toVertex a info f - -toVertex1 :: (VertexDeclaration1 f, VertexDeclaration t, Declarations (t Loc.Loc)) => Loc.Loc -> ModuleInfo -> f (t Loc.Loc) -> Maybe (ControlFlowVertex, Name) -toVertex1 = liftToVertex toVertex - -class VertexDeclaration1 syntax where - liftToVertex :: Declarations (term Loc.Loc) - => (ModuleInfo -> term Loc.Loc -> Maybe (ControlFlowVertex, Name)) - -> Loc.Loc - -> ModuleInfo - -> syntax (term Loc.Loc) - -> Maybe (ControlFlowVertex, Name) - -instance (VertexDeclarationStrategy1 syntax ~ strategy, VertexDeclarationWithStrategy1 strategy syntax) => VertexDeclaration1 syntax where - liftToVertex = liftToVertexWithStrategy (Proxy :: Proxy strategy) - --- | This appears to be required to convince 'Semantic.Graph.runCallGraph' not to try to specialize the instance too eagerly. -instance {-# OVERLAPPING #-} VertexDeclaration1 V1 where - liftToVertex _ _ _ v = case v of {} - -data Strategy = Default | Custom - -type family VertexDeclarationStrategy1 syntax where - VertexDeclarationStrategy1 Syntax.Identifier = 'Custom - VertexDeclarationStrategy1 Declaration.Function = 'Custom - VertexDeclarationStrategy1 Declaration.Method = 'Custom - VertexDeclarationStrategy1 Expression.MemberAccess = 'Custom - VertexDeclarationStrategy1 (Sum _) = 'Custom - VertexDeclarationStrategy1 _ = 'Default - -class VertexDeclarationWithStrategy1 (strategy :: Strategy) syntax where - liftToVertexWithStrategy :: Declarations (term Loc.Loc) - => proxy strategy - -> (ModuleInfo -> term Loc.Loc -> Maybe (ControlFlowVertex, Name)) - -> Loc.Loc - -> ModuleInfo - -> syntax (term Loc.Loc) - -> Maybe (ControlFlowVertex, Name) - --- | The 'Default' strategy produces 'Nothing'. -instance VertexDeclarationWithStrategy1 'Default syntax where - liftToVertexWithStrategy _ _ _ _ _ = Nothing - -instance Apply VertexDeclaration1 fs => VertexDeclarationWithStrategy1 'Custom (Sum fs) where - liftToVertexWithStrategy _ toVertex ann info = apply @VertexDeclaration1 (liftToVertex toVertex ann info) - -instance VertexDeclarationWithStrategy1 'Custom Syntax.Identifier where - liftToVertexWithStrategy _ _ ann info (Syntax.Identifier name) = Just (variableVertex (formatName name) info (Loc.span ann), name) - -instance VertexDeclarationWithStrategy1 'Custom Declaration.Function where - liftToVertexWithStrategy _ _ ann info term@Declaration.Function{} = (\n -> (functionVertex (formatName n) info (Loc.span ann), n)) <$> liftDeclaredName declaredName term - -instance VertexDeclarationWithStrategy1 'Custom Declaration.Method where - liftToVertexWithStrategy _ _ ann info term@Declaration.Method{} = (\n -> (methodVertex (formatName n) info (Loc.span ann), n)) <$> liftDeclaredName declaredName term - -instance VertexDeclarationWithStrategy1 'Custom Expression.MemberAccess where - liftToVertexWithStrategy _ toVertex ann info (Expression.MemberAccess lhs rhs) = - case (toVertex info lhs, toVertex info rhs) of - (Just (Variable n _ _, _), Just (_, name)) -> Just (variableVertex (n <> "." <> formatName name) info (Loc.span ann), name) - (_, Just (_, name)) -> Just (variableVertex (formatName name) info (Loc.span ann), name) - _ -> Nothing diff --git a/src/Data/ImportPath.hs b/src/Data/ImportPath.hs deleted file mode 100644 index a12d9ba427..0000000000 --- a/src/Data/ImportPath.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -module Data.ImportPath (IsRelative(..), ImportPath(..), importPath, toName, defaultAlias) where - -import Analysis.Name -import Data.Abstract.Path (stripQuotes) -import Data.Aeson -import Data.Hashable -import Data.Text -import qualified Data.Text as T -import GHC.Generics (Generic) -import System.FilePath.Posix - -data IsRelative = Unknown | Relative | NonRelative - deriving (Bounded, Enum, Eq, Generic, Hashable, Ord, Show, ToJSON) - -data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: IsRelative } - deriving (Eq, Generic, Hashable, Ord, Show, ToJSON) - --- TODO: fix the duplication present in this and Python -importPath :: Text -> ImportPath -importPath str = let path = stripQuotes str in ImportPath (T.unpack path) (pathType path) - where - pathType xs | startsWithDot xs = Relative -- head call here is safe - | otherwise = NonRelative - startsWithDot t = fmap fst (T.uncons t) == Just '.' - -defaultAlias :: ImportPath -> Name -defaultAlias = name . T.pack . takeFileName . unPath - -toName :: ImportPath -> Name -toName = name . T.pack . unPath diff --git a/src/Data/Quieterm.hs b/src/Data/Quieterm.hs deleted file mode 100644 index 8777fd851a..0000000000 --- a/src/Data/Quieterm.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies #-} -module Data.Quieterm -( Quieterm(..) -, quieterm -) where - -import Control.Lens -import Data.Abstract.Declarations (Declarations) -import Data.Abstract.FreeVariables (FreeVariables) -import Data.Functor.Classes -import Data.Functor.Foldable -import Data.Term -import Source.Span -import Text.Show (showListWith) - -newtype Quieterm syntax ann = Quieterm { unQuieterm :: TermF syntax ann (Quieterm syntax ann) } - deriving (Declarations, FreeVariables) - -type instance Base (Quieterm syntax ann) = TermF syntax ann -instance Functor syntax => Recursive (Quieterm syntax ann) where project = unQuieterm -instance Functor syntax => Corecursive (Quieterm syntax ann) where embed = Quieterm - -instance Eq1 syntax => Eq1 (Quieterm syntax) where - liftEq eqA = go where go t1 t2 = liftEq2 eqA go (unQuieterm t1) (unQuieterm t2) - -instance (Eq1 syntax, Eq ann) => Eq (Quieterm syntax ann) where - (==) = eq1 - -instance Ord1 syntax => Ord1 (Quieterm syntax) where - liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unQuieterm t1) (unQuieterm t2) - -instance (Ord1 syntax, Ord ann) => Ord (Quieterm syntax ann) where - compare = compare1 - -instance Show1 syntax => Show1 (Quieterm syntax) where - liftShowsPrec _ _ = go where go d = liftShowsPrec go (showListWith (go 0)) d . termFOut . unQuieterm - -instance Show1 syntax => Show (Quieterm syntax ann) where - showsPrec = liftShowsPrec (const (const id)) (const id) - -instance HasSpan ann => HasSpan (Quieterm syntax ann) where - span_ = lens (view span_ . unQuieterm) (\(Quieterm i) s -> Quieterm (set span_ s i)) - {-# INLINE span_ #-} - -quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann -quieterm = cata Quieterm diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs deleted file mode 100644 index 0e880bb99c..0000000000 --- a/src/Data/Syntax.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Syntax (module Data.Syntax) where - - -import qualified Assigning.Assignment as Assignment -import Control.Abstract.Heap (deref, lookupSlot) -import Control.Abstract.ScopeGraph (Declaration (..), Reference (..), reference) -import Data.Abstract.Evaluatable hiding (Empty, Error) -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Aeson as Aeson (ToJSON (..), object) -import Data.Aeson ((.=)) -import Data.Bifunctor -import qualified Data.Error as Error -import Data.Foldable -import Data.Function -import Data.Functor.Classes -import Data.Functor.Classes.Generic -import Data.Functor.Foldable (cata) -import Data.Hashable -import Data.Hashable.Lifted -import Data.Ix -import Data.List.NonEmpty (NonEmpty (..), nonEmpty) -import Data.Proxy -import Data.Semigroup (sconcat) -import qualified Data.Set as Set -import Data.Sum -import Data.Term -import Data.Text (Text) -import GHC.Generics -import GHC.Stack -import GHC.TypeLits -import GHC.Types (Constraint) -import Source.Loc -import Source.Range as Range -import Source.Span as Span - --- Combinators - --- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. -makeTerm :: (Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, IsTerm term) => ann -> syntax (term ann) -> term ann -makeTerm ann = makeTerm' ann . inject - --- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children. -makeTerm' :: (Semigroup ann, Foldable (Syntax term), IsTerm term) => ann -> Syntax term (term ann) -> term ann -makeTerm' ann syntax = termIn (sconcat (ann :| (termAnnotation <$> toList syntax))) syntax - --- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. Removes extra structure if term is a list of a single item. -makeTerm'' :: (Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, Foldable syntax, IsTerm term) => ann -> syntax (term ann) -> term ann -makeTerm'' ann children = case toList children of - [x] -> x - _ -> makeTerm' ann (inject children) - --- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation. -makeTerm1 :: (HasCallStack, Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, IsTerm term) => syntax (term ann) -> term ann -makeTerm1 = makeTerm1' . inject - --- | Lift a non-empty union into a term, appending all subterms’ annotations to make the new term’s annotation. -makeTerm1' :: (HasCallStack, Semigroup ann, Foldable (Syntax term), IsTerm term) => Syntax term (term ann) -> term ann -makeTerm1' syntax = case toList syntax of - a : _ -> makeTerm' (termAnnotation a) syntax - _ -> error "makeTerm1': empty structure" - --- | Construct an empty term at the current position. -emptyTerm :: (Empty :< syntaxes, Sum syntaxes ~ Syntax term, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment grammar (term Loc) -emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty - where startLocation Loc{..} = Loc (Range.point (Range.start byteRange)) (Span.point (Span.start span)) - --- | Catch assignment errors into an error term. -handleError :: (HasCallStack, Error :< syntaxes, Sum syntaxes ~ Syntax term, Enum grammar, Ix grammar, Show grammar, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment grammar (term Loc) -> Assignment.Assignment grammar (term Loc) -handleError = flip Assignment.catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source) - --- | Catch parse errors into an error term. -parseError :: (Error :< syntaxes, Sum syntaxes ~ Syntax term, Bounded grammar, Enum grammar, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment grammar (term Loc) -parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack $ errorSite <$> getCallStack (freezeCallStack callStack)) [] (Just "ParseError") []) - --- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term. -contextualize :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term) - => m (term ann) - -> m (term ann) - -> m (term ann) -contextualize context rule = make <$> Assignment.manyThrough context rule - where make (cs, node) = case nonEmpty cs of - Just cs -> makeTerm1 (Context cs node) - _ -> node - --- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise. -postContextualizeThrough :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term) - => m (term ann) - -> m (term ann) - -> m delimiter - -> m (term ann, delimiter) -postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end - where make node (cs, end) = case nonEmpty cs of - Just cs -> (makeTerm1 (Context cs node), end) - _ -> (node, end) - --- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term. -postContextualize :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term) - => m (term ann) - -> m (term ann) - -> m (term ann) -postContextualize context rule = make <$> rule <*> many context - where make node cs = case nonEmpty cs of - Just cs -> makeTerm1 (Context cs node) - _ -> node - --- | Match infix terms separated by any of a list of operators, with optional context terms following each operand. -infixContext :: (Context :< syntaxes, Sum syntaxes ~ Syntax term, Assignment.Parsing m, Semigroup ann, HasCallStack, Apply Foldable syntaxes, IsTerm term) - => m (term ann) - -> m (term ann) - -> m (term ann) - -> [m (term ann -> term ann -> Sum syntaxes (term ann))] - -> m (Sum syntaxes (term ann)) -infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right - -class Generate (c :: (* -> *) -> Constraint) (all :: [* -> *]) (fs :: [* -> *]) where - generate :: Monoid b => (forall f proxy. (Element f all, c f) => proxy f -> Integer -> b) -> b - -instance Generate c all '[] where - generate _ = mempty - -instance (Element f all, c f, Generate c all fs) => Generate c all (f ': fs) where - generate each = each (Proxy @f) (natVal (Proxy @(ElemIndex f all))) `mappend` generate @c @all @fs each - - --- Common - --- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable). -newtype Identifier a = Identifier { name :: Name } - deriving (Foldable, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Identifier where liftEq = genericLiftEq -instance Ord1 Identifier where liftCompare = genericLiftCompare -instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec - - -instance Evaluatable Identifier where - eval eval ref' term@(Identifier name) = do - -- TODO: Set the span up correctly in ref so we can move the `reference` call there. - span <- ask @Span - reference (Reference name) span ScopeGraph.Identifier (Declaration name) - deref =<< ref eval ref' term - - ref _ _ (Identifier name) = lookupSlot (Declaration name) - - -instance FreeVariables1 Identifier where - liftFreeVariables _ (Identifier x) = Set.singleton x - -instance Declarations1 Identifier where - liftDeclaredName _ (Identifier x) = pure x - liftDeclaredAlias _ (Identifier x) = pure x - --- | An accessibility modifier, e.g. private, public, protected, etc. -newtype AccessibilityModifier a = AccessibilityModifier { contents :: Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 AccessibilityModifier where liftEq = genericLiftEq -instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare -instance Show1 AccessibilityModifier where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for AccessibilityModifier -instance Evaluatable AccessibilityModifier - --- | Empty syntax, with essentially no-op semantics. --- --- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'. -data Empty a = Empty - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Empty where liftEq = genericLiftEq -instance Ord1 Empty where liftCompare = genericLiftCompare -instance Show1 Empty where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Empty where - eval _ _ _ = unit - --- | Syntax representing a parsing or assignment error. -data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Error where liftEq = genericLiftEq -instance Ord1 Error where liftCompare = genericLiftCompare -instance Show1 Error where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Error - -errorSyntax :: Error.Error String -> [a] -> Error a -errorSyntax Error.Error{..} = Error (ErrorStack $ errorSite <$> getCallStack callStack) errorExpected errorActual - -unError :: Span -> Error a -> Error.Error String -unError span Error{..} = Error.Error span errorExpected errorActual stack - where stack = fromCallSiteList $ unErrorSite <$> unErrorStack errorCallStack - -data ErrorSite = ErrorSite { errorMessage :: String, errorLocation :: SrcLoc } - deriving (Eq, Show, Generic) - -errorSite :: (String, SrcLoc) -> ErrorSite -errorSite = uncurry ErrorSite - -unErrorSite :: ErrorSite -> (String, SrcLoc) -unErrorSite ErrorSite{..} = (errorMessage, errorLocation) - -newtype ErrorStack = ErrorStack { unErrorStack :: [ErrorSite] } - deriving (Eq, Show, Generic) - -instance ToJSON ErrorStack where - toJSON (ErrorStack es) = toJSON (jSite <$> es) where - jSite (ErrorSite site SrcLoc{..}) = Aeson.object - [ "site" .= site - , "package" .= srcLocPackage - , "module" .= srcLocModule - , "file" .= srcLocFile - , "startLine" .= srcLocStartLine - , "startColumn" .= srcLocStartCol - , "endColumn" .= srcLocEndCol - ] - -instance Hashable ErrorStack where - hashWithSalt = hashUsing (map (second ((,,,,,,) <$> srcLocPackage <*> srcLocModule <*> srcLocFile <*> srcLocStartLine <*> srcLocStartCol <*> srcLocEndLine <*> srcLocEndCol) . unErrorSite) . unErrorStack) - -instance Ord ErrorStack where - compare = liftCompare (liftCompare compareSrcLoc) `on` (fmap unErrorSite . unErrorStack) - where compareSrcLoc s1 s2 = mconcat - [ (compare `on` srcLocPackage) s1 s2 - , (compare `on` srcLocModule) s1 s2 - , (compare `on` srcLocFile) s1 s2 - , (compare `on` srcLocStartLine) s1 s2 - , (compare `on` srcLocStartCol) s1 s2 - , (compare `on` srcLocEndLine) s1 s2 - , (compare `on` srcLocEndCol) s1 s2 - ] - - -class HasErrors term where - getErrors :: term Loc -> [Error.Error String] - -instance (Error :< fs, Apply Foldable fs, Apply Functor fs) => HasErrors (Term (Sum fs)) where - getErrors = cata $ \ (In Loc{..} syntax) -> - maybe (fold syntax) (pure . unError span) (Data.Sum.project syntax) - - -data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a } - deriving (Foldable, FreeVariables1, Functor, Generic1, Traversable) - -instance Eq1 Context where liftEq = genericLiftEq -instance Ord1 Context where liftCompare = genericLiftCompare -instance Show1 Context where liftShowsPrec = genericLiftShowsPrec - -instance Hashable1 Context where liftHashWithSalt = foldl - -instance Evaluatable Context where - eval eval _ Context{..} = eval contextSubject - -instance Declarations1 Context where - liftDeclaredName declaredName = declaredName . contextSubject diff --git a/src/Data/Syntax/Comment.hs b/src/Data/Syntax/Comment.hs deleted file mode 100644 index 485f6113de..0000000000 --- a/src/Data/Syntax/Comment.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Data.Syntax.Comment (module Data.Syntax.Comment) where - -import Data.Abstract.Evaluatable -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import Data.Text (Text) -import GHC.Generics (Generic1) - --- | An unnested comment (line or block). -newtype Comment a = Comment { commentContent :: Text } - deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1) - -instance Eq1 Comment where liftEq = genericLiftEq -instance Ord1 Comment where liftCompare = genericLiftCompare -instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Comment where - eval _ _ _ = unit - --- TODO: nested comment types --- TODO: documentation comment types --- TODO: literate programming comment types? alternatively, consider those as markup --- TODO: Differentiate between line/block comments? - --- | HashBang line (e.g. `#!/usr/bin/env node`) -newtype HashBang a = HashBang { value :: Text } - deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1) - -instance Eq1 HashBang where liftEq = genericLiftEq -instance Ord1 HashBang where liftCompare = genericLiftCompare -instance Show1 HashBang where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for HashBang -instance Evaluatable HashBang diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs deleted file mode 100644 index 49184c783e..0000000000 --- a/src/Data/Syntax/Declaration.hs +++ /dev/null @@ -1,363 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Syntax.Declaration (module Data.Syntax.Declaration) where - - -import Control.Lens.Getter -import Control.Monad -import Data.Foldable -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import qualified Data.Map.Strict as Map -import Data.Maybe.Exts -import qualified Data.Set as Set -import Data.Traversable -import GHC.Generics (Generic1) - -import Control.Abstract hiding (AccessControl (..), Function) -import Data.Abstract.Evaluatable -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Source.Span - -data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a } - deriving (Foldable, Traversable, Functor, Generic1, Hashable1) - -instance Eq1 Function where liftEq = genericLiftEq -instance Ord1 Function where liftCompare = genericLiftCompare -instance Show1 Function where liftShowsPrec = genericLiftShowsPrec - --- TODO: Filter the closed-over environment by the free variables in the term. --- TODO: How should we represent function types, where applicable? - -instance Evaluatable Function where - eval _ _ Function{..} = do - current <- ask @Span - (name, associatedScope) <- declareFunction (declaredName functionName) ScopeGraph.Public current ScopeGraph.Function - - params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span_) ScopeGraph.Parameter Nothing - - addr <- lookupSlot (Declaration name) - v <- function name params functionBody associatedScope - v <$ assign addr v - -declareFunction :: ( Has (State (ScopeGraph address)) sig m - , Has (Allocator address) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has Fresh sig m - , Ord address - ) - => Maybe Name - -> ScopeGraph.AccessControl - -> Span - -> ScopeGraph.Kind - -> Evaluator term address value m (Name, address) -declareFunction name accessControl span kind = do - currentScope' <- currentScope - let lexicalEdges = Map.singleton Lexical [ currentScope' ] - associatedScope <- newScope lexicalEdges - name' <- declareMaybeName name Default accessControl span kind (Just associatedScope) - pure (name', associatedScope) - - -instance Declarations1 Function where - liftDeclaredName declaredName = declaredName . functionName - -instance FreeVariables1 Function where - liftFreeVariables freeVariables f@Function{..} = foldMap freeVariables f `Set.difference` foldMap freeVariables functionParameters - -data Method a = Method - { methodContext :: [a] - , methodReceiver :: a - , methodName :: a - , methodParameters :: [a] - , methodBody :: a - , methodAccessControl :: ScopeGraph.AccessControl - } - deriving (Foldable, Traversable, Functor, Generic1, Hashable1) - -instance Eq1 Method where liftEq = genericLiftEq -instance Ord1 Method where liftCompare = genericLiftCompare -instance Show1 Method where liftShowsPrec = genericLiftShowsPrec - --- Evaluating a Method creates a closure and makes that value available in the --- local environment. -instance Evaluatable Method where - eval _ _ Method{..} = do - current <- ask @Span - (name, associatedScope) <- declareFunction (declaredName methodName) methodAccessControl current ScopeGraph.Method - - params <- withScope associatedScope $ do - -- TODO: Should we give `self` a special Relation? - declare (Declaration __self) ScopeGraph.Prelude ScopeGraph.Public (point (Pos 1 1)) ScopeGraph.Unknown Nothing - for methodParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span_) ScopeGraph.Parameter Nothing - - addr <- lookupSlot (Declaration name) - v <- function name params methodBody associatedScope - v <$ assign addr v - -instance Declarations1 Method where - liftDeclaredName declaredName = declaredName . methodName - -instance FreeVariables1 Method where - liftFreeVariables freeVariables m@Method{..} = foldMap freeVariables m `Set.difference` foldMap freeVariables methodParameters - - --- | A method signature in TypeScript or a method spec in Go. -data MethodSignature a = MethodSignature - { methodSignatureContext :: [a] - , methodSignatureName :: a - , methodSignatureParameters :: [a] - , methodSignatureAccessControl :: ScopeGraph.AccessControl - } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 MethodSignature where liftEq = genericLiftEq -instance Ord1 MethodSignature where liftCompare = genericLiftCompare -instance Show1 MethodSignature where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for MethodSignature -instance Evaluatable MethodSignature - - -newtype RequiredParameter a = RequiredParameter { requiredParameter :: a } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 RequiredParameter where liftEq = genericLiftEq -instance Ord1 RequiredParameter where liftCompare = genericLiftCompare -instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 RequiredParameter where - liftDeclaredName declaredName = declaredName . requiredParameter - --- TODO: Implement Eval instance for RequiredParameter -instance Evaluatable RequiredParameter where - eval _ _ RequiredParameter{..} = do - span <- ask @Span - _ <- declareMaybeName (declaredName requiredParameter) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing - unit - - -newtype OptionalParameter a = OptionalParameter { optionalParameter :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 OptionalParameter where liftEq = genericLiftEq -instance Ord1 OptionalParameter where liftCompare = genericLiftCompare -instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for OptionalParameter -instance Evaluatable OptionalParameter - - --- TODO: Should we replace this with Function and differentiate by context? --- TODO: How should we distinguish class/instance methods? --- TODO: It would be really nice to have a more meaningful type contained in here than [a] --- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript. -newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 VariableDeclaration where liftEq = genericLiftEq -instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare -instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable VariableDeclaration where - eval _ _ (VariableDeclaration []) = unit - eval eval _ (VariableDeclaration decs) = do - for_ decs $ \declaration -> do - _ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public (declaration^.span_) ScopeGraph.VariableDeclaration Nothing - eval declaration - unit - -instance Declarations a => Declarations (VariableDeclaration a) where - declaredName (VariableDeclaration vars) = case vars of - [var] -> declaredName var - _ -> Nothing - - --- | A TypeScript/Java style interface declaration to implement. - -data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationSuperInterfaces :: ![a], interfaceDeclarationBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq -instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare -instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for InterfaceDeclaration -instance Evaluatable InterfaceDeclaration - -instance Declarations a => Declarations (InterfaceDeclaration a) where - declaredName InterfaceDeclaration{..} = declaredName interfaceDeclarationIdentifier - - --- | A public field definition such as a field definition in a JavaScript class. -data PublicFieldDefinition a = PublicFieldDefinition - { publicFieldContext :: [a] - , publicFieldPropertyName :: a - , publicFieldValue :: a - , publicFieldAccessControl :: ScopeGraph.AccessControl - } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 PublicFieldDefinition where liftEq = genericLiftEq -instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare -instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for PublicFieldDefinition -instance Evaluatable PublicFieldDefinition where - eval eval _ PublicFieldDefinition{..} = do - span <- ask @Span - name <- declareMaybeName (declaredName publicFieldPropertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing - slot <- lookupSlot (Declaration name) - value <- eval publicFieldValue - assign slot value - unit - -data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Variable where liftEq = genericLiftEq -instance Ord1 Variable where liftCompare = genericLiftCompare -instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Variable -instance Evaluatable Variable - -data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a } - deriving (Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1) - -instance Eq1 Class where liftEq = genericLiftEq -instance Ord1 Class where liftCompare = genericLiftCompare -instance Show1 Class where liftShowsPrec = genericLiftShowsPrec - -instance Declarations a => Declarations (Class a) where - declaredName (Class _ name _ _) = declaredName name - -instance Evaluatable Class where - eval eval _ Class{..} = do - span <- ask @Span - currentScope' <- currentScope - - superScopes <- for classSuperclasses $ \superclass -> do - name <- maybeM gensym (declaredName superclass) - scope <- associatedScope (Declaration name) - slot <- lookupSlot (Declaration name) - superclassFrame <- scopedEnvironment =<< deref slot - pure $ case (scope, superclassFrame) of - (Just scope, Just frame) -> Just (scope, frame) - _ -> Nothing - - let superclassEdges = (Superclass, ) . pure . fst <$> catMaybes superScopes - current = (Lexical, ) <$> pure (pure currentScope') - edges = Map.fromList (superclassEdges <> current) - classScope <- newScope edges - name <- declareMaybeName (declaredName classIdentifier) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope) - - let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes)) - classFrame <- newFrame classScope frameEdges - - classSlot <- lookupSlot (Declaration name) - assign classSlot =<< klass (Declaration name) classFrame - - withScopeAndFrame classFrame $ do - void $ eval classBody - - unit - -instance Declarations1 Class where - liftDeclaredName declaredName = declaredName . classIdentifier - --- | A decorator in Python -data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Decorator where liftEq = genericLiftEq -instance Ord1 Decorator where liftCompare = genericLiftCompare -instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Decorator -instance Evaluatable Decorator - --- TODO: Generics, constraints. - - --- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift. -data Datatype a = Datatype { datatypeContext :: a, datatypeName :: a, datatypeConstructors :: [a], datatypeDeriving :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Datatype where liftEq = genericLiftEq -instance Ord1 Datatype where liftCompare = genericLiftCompare -instance Show1 Datatype where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Datatype -instance Evaluatable Data.Syntax.Declaration.Datatype - - --- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift. -data Constructor a = Constructor { constructorContext :: [a], constructorName :: a, constructorFields :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Constructor where liftEq = genericLiftEq -instance Ord1 Constructor where liftCompare = genericLiftCompare -instance Show1 Constructor where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Constructor -instance Evaluatable Data.Syntax.Declaration.Constructor - - --- | Comprehension (e.g. ((a for b in c if a()) in Python) -data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Comprehension where liftEq = genericLiftEq -instance Ord1 Comprehension where liftCompare = genericLiftCompare -instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Comprehension -instance Evaluatable Comprehension - - --- | A declared type (e.g. `a []int` in Go). -data Type a = Type { typeName :: !a, typeKind :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Type where liftEq = genericLiftEq -instance Ord1 Type where liftCompare = genericLiftCompare -instance Show1 Type where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Type -instance Evaluatable Type - - --- | Type alias declarations in Javascript/Haskell, etc. -data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeAlias where liftEq = genericLiftEq -instance Ord1 TypeAlias where liftCompare = genericLiftCompare -instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeAlias where - eval _ _ TypeAlias{..} = do - -- This use of `throwNoNameError` is good -- we aren't declaring something new so `declareMaybeName` is not useful here. - kindName <- maybeM (throwNoNameError typeAliasKind) (declaredName typeAliasKind) - span <- ask @Span - assocScope <- associatedScope (Declaration kindName) - name <- declareMaybeName (declaredName typeAliasIdentifier) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope - - slot <- lookupSlot (Declaration name) - kindSlot <- lookupSlot (Declaration kindName) - assign slot =<< deref kindSlot - - unit - -instance Declarations a => Declarations (TypeAlias a) where - declaredName TypeAlias{..} = declaredName typeAliasIdentifier diff --git a/src/Data/Syntax/Directive.hs b/src/Data/Syntax/Directive.hs deleted file mode 100644 index 4d8d27a79f..0000000000 --- a/src/Data/Syntax/Directive.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Syntax.Directive (module Data.Syntax.Directive) where - -import Data.Abstract.Evaluatable -import Data.Abstract.Module (ModuleInfo (..)) -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import qualified Data.Text as T -import GHC.Generics (Generic1) -import Source.Span -import qualified System.Path as Path - --- A file directive like the Ruby constant `__FILE__`. -data File a = File - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 File where liftEq = genericLiftEq -instance Ord1 File where liftCompare = genericLiftCompare -instance Show1 File where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable File where - eval _ _ File = currentModule >>= string . T.pack . Path.toString . modulePath - - --- A line directive like the Ruby constant `__LINE__`. -data Line a = Line - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Line where liftEq = genericLiftEq -instance Ord1 Line where liftCompare = genericLiftCompare -instance Show1 Line where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Line where - eval _ _ Line = currentSpan >>= integer . fromIntegral . line . start diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs deleted file mode 100644 index beb7ae5ef1..0000000000 --- a/src/Data/Syntax/Expression.hs +++ /dev/null @@ -1,642 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Syntax.Expression (module Data.Syntax.Expression) where - -import Prelude hiding (null) - -import Analysis.Name as Name -import Control.Abstract hiding (Bitwise (..), Call, Void) -import Control.Applicative -import Control.Monad -import Data.Abstract.Evaluatable as Abstract -import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv) -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Bits -import Data.Fixed -import Data.Foldable (for_) -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import Data.List (find) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Maybe.Exts -import GHC.Generics (Generic1) - --- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell. -data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Call where liftEq = genericLiftEq -instance Ord1 Call where liftCompare = genericLiftCompare -instance Show1 Call where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 Call where - liftDeclaredName declaredName Call{..} = declaredName callFunction - -instance Evaluatable Call where - eval eval _ Call{..} = do - op <- eval callFunction - args <- traverse eval callParams - call op args - -data LessThan a = LessThan { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 LessThan where liftEq = genericLiftEq -instance Ord1 LessThan where liftCompare = genericLiftCompare -instance Show1 LessThan where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LessThan where - eval eval _ t = traverse eval t >>= go where - go (LessThan a b) = liftComparison (Concrete (<)) a b - -data LessThanEqual a = LessThanEqual { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 LessThanEqual where liftEq = genericLiftEq -instance Ord1 LessThanEqual where liftCompare = genericLiftCompare -instance Show1 LessThanEqual where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LessThanEqual where - eval eval _ t = traverse eval t >>= go where - go (LessThanEqual a b) = liftComparison (Concrete (<=)) a b - -data GreaterThan a = GreaterThan { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 GreaterThan where liftEq = genericLiftEq -instance Ord1 GreaterThan where liftCompare = genericLiftCompare -instance Show1 GreaterThan where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable GreaterThan where - eval eval _ t = traverse eval t >>= go where - go (GreaterThan a b) = liftComparison (Concrete (>)) a b - -data GreaterThanEqual a = GreaterThanEqual { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 GreaterThanEqual where liftEq = genericLiftEq -instance Ord1 GreaterThanEqual where liftCompare = genericLiftCompare -instance Show1 GreaterThanEqual where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable GreaterThanEqual where - eval eval _ t = traverse eval t >>= go where - go (GreaterThanEqual a b) = liftComparison (Concrete (>=)) a b - -data Equal a = Equal { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Equal where liftEq = genericLiftEq -instance Ord1 Equal where liftCompare = genericLiftCompare -instance Show1 Equal where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Equal where - eval eval _ t = traverse eval t >>= go where - -- TODO: in PHP and JavaScript, the equals operator performs type coercion. - -- We need some mechanism to customize this behavior per-language. - go (Equal a b) = liftComparison (Concrete (==)) a b - -data StrictEqual a = StrictEqual { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 StrictEqual where liftEq = genericLiftEq -instance Ord1 StrictEqual where liftCompare = genericLiftCompare -instance Show1 StrictEqual where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable StrictEqual where - eval eval _ t = traverse eval t >>= go where - -- TODO: in PHP and JavaScript, the equals operator performs type coercion. - -- We need some mechanism to customize this behavior per-language. - go (StrictEqual a b) = liftComparison (Concrete (==)) a b - -data Comparison a = Comparison { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Comparison where liftEq = genericLiftEq -instance Ord1 Comparison where liftCompare = genericLiftCompare -instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Comparison where - eval eval _ t = traverse eval t >>= go where - go (Comparison a b) = liftComparison (Concrete (==)) a b - -data Plus a = Plus { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Plus where liftEq = genericLiftEq -instance Ord1 Plus where liftCompare = genericLiftCompare -instance Show1 Plus where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Plus where - eval eval _ t = traverse eval t >>= go where - go (Plus a b) = liftNumeric2 add a b where add = liftReal (+) - -data Minus a = Minus { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Minus where liftEq = genericLiftEq -instance Ord1 Minus where liftCompare = genericLiftCompare -instance Show1 Minus where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Minus where - eval eval _ t = traverse eval t >>= go where - go (Minus a b) = liftNumeric2 (liftReal (-)) a b - -data Times a = Times { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Times where liftEq = genericLiftEq -instance Ord1 Times where liftCompare = genericLiftCompare -instance Show1 Times where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Times where - eval eval _ t = traverse eval t >>= go where - go (Times a b) = liftNumeric2 (liftReal (*)) a b - -data DividedBy a = DividedBy { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 DividedBy where liftEq = genericLiftEq -instance Ord1 DividedBy where liftCompare = genericLiftCompare -instance Show1 DividedBy where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable DividedBy where - eval eval _ t = traverse eval t >>= go where - go (DividedBy a b) = liftNumeric2 (liftIntegralFrac div (/)) a b - -data Modulo a = Modulo { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Modulo where liftEq = genericLiftEq -instance Ord1 Modulo where liftCompare = genericLiftCompare -instance Show1 Modulo where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Modulo where - eval eval _ t = traverse eval t >>= go where - go (Modulo a b) = liftNumeric2 (liftIntegralFrac mod mod') a b - -data Power a = Power { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Power where liftEq = genericLiftEq -instance Ord1 Power where liftCompare = genericLiftCompare -instance Show1 Power where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Power where - eval eval _ t = traverse eval t >>= go where - go (Power a b) = liftNumeric2 liftedExponent a b - -newtype Negate a = Negate { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Negate where liftEq = genericLiftEq -instance Ord1 Negate where liftCompare = genericLiftCompare -instance Show1 Negate where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Negate where - eval eval _ t = traverse eval t >>= go where - go (Negate a) = liftNumeric negate a - -data FloorDivision a = FloorDivision { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 FloorDivision where liftEq = genericLiftEq -instance Ord1 FloorDivision where liftCompare = genericLiftCompare -instance Show1 FloorDivision where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FloorDivision where - eval eval _ t = traverse eval t >>= go where - go (FloorDivision a b) = liftNumeric2 liftedFloorDiv a b - --- | Regex matching operators (Ruby's =~ and ~!) -data Matches a = Matches { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Matches where liftEq = genericLiftEq -instance Ord1 Matches where liftCompare = genericLiftCompare -instance Show1 Matches where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Matches - -data NotMatches a = NotMatches { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NotMatches where liftEq = genericLiftEq -instance Ord1 NotMatches where liftCompare = genericLiftCompare -instance Show1 NotMatches where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NotMatches - -data Or a = Or { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Or where liftEq = genericLiftEq -instance Ord1 Or where liftCompare = genericLiftCompare -instance Show1 Or where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Or where - eval eval _ (Or a b) = do - a' <- eval a - ifthenelse a' (pure a') (eval b) - -data And a = And { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 And where liftEq = genericLiftEq -instance Ord1 And where liftCompare = genericLiftCompare -instance Show1 And where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable And where - eval eval _ (And a b) = do - a' <- eval a - ifthenelse a' (eval b) (pure a') - -newtype Not a = Not { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Not where liftEq = genericLiftEq -instance Ord1 Not where liftCompare = genericLiftCompare -instance Show1 Not where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Not where - eval eval _ (Not a) = eval a >>= asBool >>= boolean . not - -data XOr a = XOr { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 XOr where liftEq = genericLiftEq -instance Ord1 XOr where liftCompare = genericLiftCompare -instance Show1 XOr where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable XOr where - -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands - eval eval _ (XOr a b) = liftA2 (/=) (eval a >>= asBool) (eval b >>= asBool) >>= boolean - --- | Javascript delete operator -newtype Delete a = Delete { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Delete where liftEq = genericLiftEq -instance Ord1 Delete where liftCompare = genericLiftCompare -instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Delete where - eval _ ref (Delete a) = ref a >>= dealloc >> unit - --- | A sequence expression such as Javascript or C's comma operator. -data SequenceExpression a = SequenceExpression { firstExpression :: !a, secondExpression :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 SequenceExpression where liftEq = genericLiftEq -instance Ord1 SequenceExpression where liftCompare = genericLiftCompare -instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable SequenceExpression where - eval eval _ (SequenceExpression a b) = - eval a >> eval b - --- | Javascript void operator -newtype Void a = Void { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Void where liftEq = genericLiftEq -instance Ord1 Void where liftCompare = genericLiftCompare -instance Show1 Void where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Void where - eval eval _ (Void a) = - eval a >> pure null - --- | Javascript typeof operator -newtype Typeof a = Typeof { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Typeof where liftEq = genericLiftEq -instance Ord1 Typeof where liftCompare = genericLiftCompare -instance Show1 Typeof where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Typeof -instance Evaluatable Typeof - --- | Bitwise operators. -data BOr a = BOr { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 BOr where liftEq = genericLiftEq -instance Ord1 BOr where liftCompare = genericLiftCompare -instance Show1 BOr where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable BOr where - eval eval _ (BOr a b) = do - a' <- eval a >>= castToInteger - b' <- eval b >>= castToInteger - liftBitwise2 (.|.) a' b' - -data BAnd a = BAnd { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 BAnd where liftEq = genericLiftEq -instance Ord1 BAnd where liftCompare = genericLiftCompare -instance Show1 BAnd where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable BAnd where - eval eval _ (BAnd a b) = do - a' <- eval a >>= castToInteger - b' <- eval b >>= castToInteger - liftBitwise2 (.&.) a' b' - -data BXOr a = BXOr { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 BXOr where liftEq = genericLiftEq -instance Ord1 BXOr where liftCompare = genericLiftCompare -instance Show1 BXOr where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable BXOr where - eval eval _ (BXOr a b) = do - a' <- eval a >>= castToInteger - b' <- eval b >>= castToInteger - liftBitwise2 xor a' b' - -data LShift a = LShift { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 LShift where liftEq = genericLiftEq -instance Ord1 LShift where liftCompare = genericLiftCompare -instance Show1 LShift where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LShift where - eval eval _ (LShift a b) = do - a' <- eval a >>= castToInteger - b' <- eval b >>= castToInteger - liftBitwise2 shiftL' a' b' - where - shiftL' a b = shiftL a (fromIntegral (toInteger b)) - -data RShift a = RShift { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 RShift where liftEq = genericLiftEq -instance Ord1 RShift where liftCompare = genericLiftCompare -instance Show1 RShift where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable RShift where - eval eval _ (RShift a b) = do - a' <- eval a >>= castToInteger - b' <- eval b >>= castToInteger - liftBitwise2 shiftR' a' b' - where - shiftR' a b = shiftR a (fromIntegral (toInteger b)) - -data UnsignedRShift a = UnsignedRShift { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 UnsignedRShift where liftEq = genericLiftEq -instance Ord1 UnsignedRShift where liftCompare = genericLiftCompare -instance Show1 UnsignedRShift where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable UnsignedRShift where - eval eval _ (UnsignedRShift a b) = do - a' <- eval a >>= castToInteger - b' <- eval b >>= castToInteger - unsignedRShift a' b' - -newtype Complement a = Complement { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Complement where liftEq = genericLiftEq -instance Ord1 Complement where liftCompare = genericLiftCompare -instance Show1 Complement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Complement where - eval eval _ (Complement a) = do - a' <- eval a >>= castToInteger - liftBitwise complement a' - --- | Member Access (e.g. a.b) -data MemberAccess a = MemberAccess { lhs :: a, rhs :: a } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 MemberAccess where liftEq = genericLiftEq -instance Ord1 MemberAccess where liftCompare = genericLiftCompare -instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 MemberAccess where - liftDeclaredName declaredName MemberAccess{..} = declaredName rhs - -instance Evaluatable MemberAccess where - eval eval ref MemberAccess{..} = do - lhsValue <- eval lhs - lhsFrame <- Abstract.scopedEnvironment lhsValue - - rhsSlot <- case lhsFrame of - Just lhsFrame -> - -- FIXME: The span is not set up correctly when calling `ref` so we have to eval - -- it first - withScopeAndFrame lhsFrame (eval rhs >> ref rhs) - -- Throw a ReferenceError since we're attempting to reference a name within a value that is not an Object. - Nothing -> throwEvalError (ReferenceError lhsValue rhs) - - rhsValue <- deref rhsSlot - rhsScope <- scopeLookup (frameAddress rhsSlot) - - let lhsAccessControl = fromMaybe Public (termToAccessControl lhs) - infos <- declarationsByAccessControl rhsScope lhsAccessControl - - -- This means we always throw an 'AccessControlError' whenever we have a rhs term whose 'declaredName' is 'Nothing'. - rhsName <- maybeM (throwNoNameError rhs) (declaredName rhs) - rhsValue' <- case find (\Info{..} -> Declaration rhsName == infoDeclaration) infos of - Just _ -> pure rhsValue - Nothing -> do - let lhsName = fromMaybe (name "") (declaredName lhs) - info <- declarationByName rhsScope (Declaration rhsName) - throwEvalError $ AccessControlError (lhsName, lhsAccessControl) (rhsName, infoAccessControl info) rhsValue - - bindThis lhsValue rhsValue' - - - ref eval ref' MemberAccess{..} = do - lhsValue <- eval lhs - lhsFrame <- Abstract.scopedEnvironment lhsValue - case lhsFrame of - Just lhsFrame -> withScopeAndFrame lhsFrame (ref' rhs) - -- Throw a ReferenceError since we're attempting to reference a name within a value that is not an Object. - Nothing -> throwEvalError (ReferenceError lhsValue rhs) - - --- | Subscript (e.g a[1]) -data Subscript a = Subscript { lhs :: a, rhs :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Subscript where liftEq = genericLiftEq -instance Ord1 Subscript where liftCompare = genericLiftCompare -instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec - --- TODO: Finish Eval instance for Subscript --- TODO return a special LvalSubscript instance here -instance Evaluatable Subscript where - eval eval _ (Subscript l [r]) = join (index <$> eval l <*> eval r) - eval _ _ (Subscript _ _) = throwUnspecializedError (UnspecializedError "Eval unspecialized for subscript with slices") - -data Member a = Member { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Member where liftEq = genericLiftEq -instance Ord1 Member where liftCompare = genericLiftCompare -instance Show1 Member where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Member where - --- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop)) -data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Enumeration where liftEq = genericLiftEq -instance Ord1 Enumeration where liftCompare = genericLiftCompare -instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Enumeration -instance Evaluatable Enumeration - --- | InstanceOf (e.g. a instanceof b in JavaScript -data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 InstanceOf where liftEq = genericLiftEq -instance Ord1 InstanceOf where liftCompare = genericLiftCompare -instance Show1 InstanceOf where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for InstanceOf -instance Evaluatable InstanceOf - - --- | ScopeResolution (e.g. import a.b in Python or a::b in C++) -newtype ScopeResolution a = ScopeResolution { scopes :: NonEmpty a } - deriving (Foldable, FreeVariables1, Functor, Generic1, Traversable) - -instance Eq1 ScopeResolution where liftEq = genericLiftEq -instance Ord1 ScopeResolution where liftCompare = genericLiftCompare -instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec - -instance Hashable1 ScopeResolution where liftHashWithSalt = foldl - -instance Evaluatable ScopeResolution - -instance Declarations1 ScopeResolution where - liftDeclaredName declaredName = declaredName . NonEmpty.last . scopes - --- | A non-null expression such as Typescript or Swift's ! expression. -newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NonNullExpression where liftEq = genericLiftEq -instance Ord1 NonNullExpression where liftCompare = genericLiftCompare -instance Show1 NonNullExpression where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for NonNullExpression -instance Evaluatable NonNullExpression - - --- | An await expression in Javascript or C#. -newtype Await a = Await { awaitSubject :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Await where liftEq = genericLiftEq -instance Ord1 Await where liftCompare = genericLiftCompare -instance Show1 Await where liftShowsPrec = genericLiftShowsPrec --- TODO: Improve this to model asynchrony or capture some data suggesting async calls are not a problem. --- We are currently dealing with an asynchronous construct synchronously. -instance Evaluatable Await where - eval eval _ (Await a) = eval a - --- | An object constructor call in Javascript, Java, etc. -data New a = New { newSubject :: a , newTypeParameters :: a, newArguments :: [a] } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 New where liftEq = genericLiftEq -instance Ord1 New where liftCompare = genericLiftCompare -instance Show1 New where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 New where - liftDeclaredName declaredName New{..} = declaredName newSubject - --- TODO: Implement Eval instance for New -instance Evaluatable New where - eval eval _ New{..} = do - name <- maybeM (throwNoNameError newSubject) (declaredName newSubject) - assocScope <- maybeM (throwEvalError $ ConstructorError name) =<< associatedScope (Declaration name) - objectScope <- newScope (Map.singleton Superclass [ assocScope ]) - slot <- lookupSlot (Declaration name) - classVal <- deref slot - classFrame <- maybeM (throwEvalError $ ScopedEnvError classVal) =<< scopedEnvironment classVal - - objectFrame <- newFrame objectScope (Map.singleton Superclass $ Map.singleton assocScope classFrame) - objectVal <- object objectFrame - - classScope <- scopeLookup classFrame - instanceMembers <- declarationsByRelation classScope Instance - - void . withScopeAndFrame objectFrame $ do - for_ instanceMembers $ \Info{..} -> do - declare infoDeclaration Default infoAccessControl infoSpan infoKind infoAssociatedScope - - -- TODO: This is a typescript specific name and we should allow languages to customize it. - let constructorName = Name.name "constructor" - maybeConstructor <- maybeLookupDeclaration (Declaration constructorName) - case maybeConstructor of - Just slot -> do - span <- ask @Span - reference (Reference constructorName) span ScopeGraph.New (Declaration constructorName) - constructor <- deref slot - args <- traverse eval newArguments - boundConstructor <- bindThis objectVal constructor - call boundConstructor args - Nothing -> pure objectVal - - pure objectVal - --- | A cast expression to a specified type. -data Cast a = Cast { castSubject :: !a, castType :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Cast where liftEq = genericLiftEq -instance Ord1 Cast where liftCompare = genericLiftCompare -instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Cast - -data Super a = Super - deriving (Foldable, Functor, Generic1, Traversable, FreeVariables1, Declarations1, Hashable1) - -instance Eq1 Super where liftEq = genericLiftEq -instance Ord1 Super where liftCompare = genericLiftCompare -instance Show1 Super where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Super - -data This a = This - deriving (Foldable, Functor, Generic1, Traversable, FreeVariables1, Declarations1, Hashable1) - -instance Eq1 This where liftEq = genericLiftEq -instance Ord1 This where liftCompare = genericLiftCompare -instance Show1 This where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable This where - eval _ _ This = do - span <- ask @Span - reference (Reference __self) span ScopeGraph.This (Declaration __self) - deref =<< lookupSlot (Declaration __self) - -instance AccessControls1 This where - liftTermToAccessControl _ _ = Just Private diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs deleted file mode 100644 index 74a9d176d6..0000000000 --- a/src/Data/Syntax/Literal.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -module Data.Syntax.Literal (module Data.Syntax.Literal) where - -import Prelude hiding (Float, null) - -import Control.Monad -import Data.Abstract.Evaluatable as Eval -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import Data.Scientific.Exts -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics (Generic1) -import Numeric.Exts -import Text.Read (readMaybe) - --- Boolean - -newtype Boolean a = Boolean { booleanContent :: Bool } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Boolean where liftEq = genericLiftEq -instance Ord1 Boolean where liftCompare = genericLiftCompare -instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec - -true :: Boolean a -true = Boolean True - -false :: Boolean a -false = Boolean False - -instance Evaluatable Boolean where - eval _ _ (Boolean x) = boolean x - --- | A literal integer of unspecified width. No particular base is implied. -newtype Integer a = Integer { integerContent :: Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq -instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare -instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Data.Syntax.Literal.Integer where - -- TODO: We should use something more robust than shelling out to readMaybe. - eval _ _ (Data.Syntax.Literal.Integer x) = - either (const (throwEvalError (IntegerFormatError x))) pure (parseInteger x) >>= integer - --- | A literal float of unspecified width. - -newtype Float a = Float { floatContent :: Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq -instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare -instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec - - -instance Evaluatable Data.Syntax.Literal.Float where - eval _ _ (Float s) = - either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s) >>= float - --- Rational literals e.g. `2/3r` -newtype Rational a = Rational { value :: Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq -instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompare -instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Data.Syntax.Literal.Rational where - eval _ _ (Rational r) = - let - trimmed = T.takeWhile (/= 'r') r - parsed = readMaybe @Prelude.Integer (T.unpack trimmed) - in maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed >>= rational - --- Complex literals e.g. `3 + 2i` -newtype Complex a = Complex { value :: Text } - deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1) - -instance Eq1 Complex where liftEq = genericLiftEq -instance Ord1 Complex where liftCompare = genericLiftCompare -instance Show1 Complex where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Complex -instance Evaluatable Complex - --- Strings, symbols - -newtype String a = String { stringElements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq -instance Ord1 Data.Syntax.Literal.String where liftCompare = genericLiftCompare -instance Show1 Data.Syntax.Literal.String where liftShowsPrec = genericLiftShowsPrec - --- TODO: Should string literal bodies include escapes too? - --- TODO: Implement Eval instance for String -instance Evaluatable Data.Syntax.Literal.String - -newtype Character a = Character { characterContent :: Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Character where liftEq = genericLiftEq -instance Ord1 Character where liftCompare = genericLiftCompare -instance Show1 Character where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Data.Syntax.Literal.Character - --- | An interpolation element within a string literal. -newtype InterpolationElement a = InterpolationElement { interpolationBody :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 InterpolationElement where liftEq = genericLiftEq -instance Ord1 InterpolationElement where liftCompare = genericLiftCompare -instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for InterpolationElement -instance Evaluatable InterpolationElement - --- | A sequence of textual contents within a string literal. -newtype TextElement a = TextElement { textElementContent :: Text } - deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1) - -instance Eq1 TextElement where liftEq = genericLiftEq -instance Ord1 TextElement where liftCompare = genericLiftCompare -instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TextElement where - eval _ _ (TextElement x) = string x - -isTripleQuoted :: TextElement a -> Bool -isTripleQuoted (TextElement t) = - let trip = "\"\"\"" - in T.take 3 t == trip && T.takeEnd 3 t == trip - -quoted :: Text -> TextElement a -quoted t = TextElement ("\"" <> t <> "\"") - --- | A sequence of textual contents within a string literal. -newtype EscapeSequence a = EscapeSequence { value :: Text } - deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1) - -instance Eq1 EscapeSequence where liftEq = genericLiftEq -instance Ord1 EscapeSequence where liftCompare = genericLiftCompare -instance Show1 EscapeSequence where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for EscapeSequence -instance Evaluatable EscapeSequence - -data Null a = Null - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Null where liftEq = genericLiftEq -instance Ord1 Null where liftCompare = genericLiftCompare -instance Show1 Null where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Null where eval _ _ _ = pure null - -newtype Symbol a = Symbol { symbolElements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Symbol where liftEq = genericLiftEq -instance Ord1 Symbol where liftCompare = genericLiftCompare -instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Symbol -instance Evaluatable Symbol - -newtype SymbolElement a = SymbolElement { symbolContent :: Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 SymbolElement where liftEq = genericLiftEq -instance Ord1 SymbolElement where liftCompare = genericLiftCompare -instance Show1 SymbolElement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable SymbolElement where - eval _ _ (SymbolElement s) = string s - -newtype Regex a = Regex { regexContent :: Text } - deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1) - -instance Eq1 Regex where liftEq = genericLiftEq -instance Ord1 Regex where liftCompare = genericLiftCompare -instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec - --- TODO: Heredoc-style string literals? - --- TODO: Implement Eval instance for Regex -instance Evaluatable Regex where - eval _ _ (Regex x) = string x - --- Collections - -newtype Array a = Array { arrayElements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Array where liftEq = genericLiftEq -instance Ord1 Array where liftCompare = genericLiftCompare -instance Show1 Array where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Array where - eval eval _ Array{..} = array =<< traverse eval arrayElements - -newtype Hash a = Hash { hashElements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Hash where liftEq = genericLiftEq -instance Ord1 Hash where liftCompare = genericLiftCompare -instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Hash where - eval eval _ t = do - elements <- traverse (eval >=> asPair) (hashElements t) - Eval.hash elements - -data KeyValue a = KeyValue { key :: !a, value :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 KeyValue where liftEq = genericLiftEq -instance Ord1 KeyValue where liftCompare = genericLiftCompare -instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable KeyValue where - eval eval _ KeyValue{..} = do - k <- eval key - v <- eval value - kvPair k v - -newtype Tuple a = Tuple { tupleContents :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Tuple where liftEq = genericLiftEq -instance Ord1 Tuple where liftCompare = genericLiftCompare -instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Tuple where - eval eval _ (Tuple cs) = tuple =<< traverse eval cs - -newtype Set a = Set { setElements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Set where liftEq = genericLiftEq -instance Ord1 Set where liftCompare = genericLiftCompare -instance Show1 Set where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Set -instance Evaluatable Set - - --- Pointers - --- | A declared pointer (e.g. var pointer *int in Go) -newtype Pointer a = Pointer { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Pointer where liftEq = genericLiftEq -instance Ord1 Pointer where liftCompare = genericLiftCompare -instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Pointer -instance Evaluatable Pointer - - --- | A reference to a pointer's address (e.g. &pointer in Go) -newtype Reference a = Reference { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Reference where liftEq = genericLiftEq -instance Ord1 Reference where liftCompare = genericLiftCompare -instance Show1 Reference where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Reference -instance Evaluatable Reference - --- TODO: Object literals as distinct from hash literals? Or coalesce object/hash literals into “key-value literals”? --- TODO: Function literals (lambdas, procs, anonymous functions, what have you). diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs deleted file mode 100644 index 1c6b956c07..0000000000 --- a/src/Data/Syntax/Statement.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -module Data.Syntax.Statement (module Data.Syntax.Statement) where - -import Control.Abstract hiding (Break, Catch, Continue, Return, Throw, While) -import Data.Abstract.Evaluatable as Abstract hiding (Catch, Throw) -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Aeson (ToJSON1 (..)) -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import Data.List.NonEmpty (nonEmpty) -import qualified Data.Map.Strict as Map -import Data.Maybe.Exts -import Data.Semigroup.App -import Data.Semigroup.Foldable -import GHC.Generics (Generic1) - --- | Imperative sequence of statements/declarations s.t.: --- --- 1. Each statement’s effects on the store are accumulated; --- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and --- 3. Only the last statement’s return value is returned. --- TODO: Separate top-level statement nodes into non-lexical Statement and lexical StatementBlock nodes -newtype Statements a = Statements { statements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Statements where liftEq = genericLiftEq -instance Ord1 Statements where liftCompare = genericLiftCompare -instance Show1 Statements where liftShowsPrec = genericLiftShowsPrec - -instance ToJSON1 Statements - -instance Evaluatable Statements where - eval eval _ (Statements xs) = - maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty xs) - -newtype StatementBlock a = StatementBlock { statements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 StatementBlock where liftEq = genericLiftEq -instance Ord1 StatementBlock where liftCompare = genericLiftCompare -instance Show1 StatementBlock where liftShowsPrec = genericLiftShowsPrec - -instance ToJSON1 StatementBlock - -instance Evaluatable StatementBlock where - eval eval _ (StatementBlock xs) = - maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty xs) - --- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted. -data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 If where liftEq = genericLiftEq -instance Ord1 If where liftCompare = genericLiftCompare -instance Show1 If where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable If where - eval eval _ (If cond if' else') = do - bool <- eval cond - ifthenelse bool (eval if') (eval else') - - --- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python. -data Else a = Else { elseCondition :: !a, elseBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Else where liftEq = genericLiftEq -instance Ord1 Else where liftCompare = genericLiftCompare -instance Show1 Else where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Else -instance Evaluatable Else - - --- TODO: Alternative definition would flatten if/else if/else chains: data If a = If ![(a, a)] !(Maybe a) - --- | Goto statement (e.g. `goto a` in Go). -newtype Goto a = Goto { gotoLocation :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Goto where liftEq = genericLiftEq -instance Ord1 Goto where liftCompare = genericLiftCompare -instance Show1 Goto where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Goto -instance Evaluatable Goto - --- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell. -data Match a = Match { matchSubject :: !a, matchPatterns :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Match where liftEq = genericLiftEq -instance Ord1 Match where liftCompare = genericLiftCompare -instance Show1 Match where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Match -instance Evaluatable Match - - --- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions. -data Pattern a = Pattern { value :: !a, patternBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Pattern where liftEq = genericLiftEq -instance Ord1 Pattern where liftCompare = genericLiftCompare -instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Pattern -instance Evaluatable Pattern - --- | A let statement or local binding, like 'a as b' or 'let a = b'. -data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Let where liftEq = genericLiftEq -instance Ord1 Let where liftCompare = genericLiftCompare -instance Show1 Let where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Let where - eval eval _ Let{..} = do - -- This use of 'throwNoNameError' is okay until we have a better way of mapping gensym names to terms in the scope graph. - valueName <- maybeM (throwNoNameError letValue) (declaredName letValue) - assocScope <- associatedScope (Declaration valueName) - - _ <- withLexicalScopeAndFrame $ do - letSpan <- ask @Span - name <- declareMaybeName (declaredName letVariable) Default Public letSpan ScopeGraph.Let assocScope - letVal <- eval letValue - slot <- lookupSlot (Declaration name) - assign slot letVal - eval letBody - unit - - --- AugmentedAssignment - -newtype AugmentedAssignment a = AugmentedAssignment { augmentedAssignmentTarget :: a } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 AugmentedAssignment where liftEq = genericLiftEq -instance Ord1 AugmentedAssignment where liftCompare = genericLiftCompare -instance Show1 AugmentedAssignment where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 AugmentedAssignment where - liftDeclaredName declaredName AugmentedAssignment{..} = declaredName augmentedAssignmentTarget - -instance Evaluatable AugmentedAssignment - - --- Assignment - --- | Assignment to a variable or other lvalue. -data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Assignment where liftEq = genericLiftEq -instance Ord1 Assignment where liftCompare = genericLiftCompare -instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 Assignment where - liftDeclaredName declaredName Assignment{..} = declaredName assignmentTarget - -instance Evaluatable Assignment where - eval eval ref Assignment{..} = do - lhs <- ref assignmentTarget - rhs <- eval assignmentValue - - case declaredName assignmentValue of - Just rhsName -> do - assocScope <- associatedScope (Declaration rhsName) - case assocScope of - Just assocScope' -> do - objectScope <- newScope (Map.singleton Import [ assocScope' ]) - putSlotDeclarationScope lhs (Just objectScope) -- TODO: not sure if this is right - Nothing -> - pure () - Nothing -> - pure () - assign lhs rhs - pure rhs - --- | Post increment operator (e.g. 1++ in Go, or i++ in C). -newtype PostIncrement a = PostIncrement { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 PostIncrement where liftEq = genericLiftEq -instance Ord1 PostIncrement where liftCompare = genericLiftCompare -instance Show1 PostIncrement where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for PostIncrement -instance Evaluatable PostIncrement - - --- | Post decrement operator (e.g. 1-- in Go, or i-- in C). -newtype PostDecrement a = PostDecrement { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 PostDecrement where liftEq = genericLiftEq -instance Ord1 PostDecrement where liftCompare = genericLiftCompare -instance Show1 PostDecrement where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for PostDecrement -instance Evaluatable PostDecrement - --- | Pre increment operator (e.g. ++1 in C or Java). -newtype PreIncrement a = PreIncrement { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 PreIncrement where liftEq = genericLiftEq -instance Ord1 PreIncrement where liftCompare = genericLiftCompare -instance Show1 PreIncrement where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for PreIncrement -instance Evaluatable PreIncrement - - --- | Pre decrement operator (e.g. --1 in C or Java). -newtype PreDecrement a = PreDecrement { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 PreDecrement where liftEq = genericLiftEq -instance Ord1 PreDecrement where liftCompare = genericLiftCompare -instance Show1 PreDecrement where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for PreDecrement -instance Evaluatable PreDecrement - - --- Returns - -newtype Return a = Return { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Return where liftEq = genericLiftEq -instance Ord1 Return where liftCompare = genericLiftCompare -instance Show1 Return where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Return where - eval eval _ (Return x) = eval x >>= earlyReturn - -newtype Yield a = Yield { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Yield where liftEq = genericLiftEq -instance Ord1 Yield where liftCompare = genericLiftCompare -instance Show1 Yield where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Yield -instance Evaluatable Yield - - -newtype Break a = Break { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Break where liftEq = genericLiftEq -instance Ord1 Break where liftCompare = genericLiftCompare -instance Show1 Break where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Break where - eval eval _ (Break x) = eval x >>= throwBreak - -newtype Continue a = Continue { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Continue where liftEq = genericLiftEq -instance Ord1 Continue where liftCompare = genericLiftCompare -instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Continue where - eval eval _ (Continue x) = eval x >>= throwContinue - -newtype Retry a = Retry { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Retry where liftEq = genericLiftEq -instance Ord1 Retry where liftCompare = genericLiftCompare -instance Show1 Retry where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Retry -instance Evaluatable Retry - -newtype NoOp a = NoOp { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NoOp where liftEq = genericLiftEq -instance Ord1 NoOp where liftCompare = genericLiftCompare -instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NoOp where - eval _ _ _ = unit - --- Loops - -data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 For where liftEq = genericLiftEq -instance Ord1 For where liftCompare = genericLiftCompare -instance Show1 For where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable For where - eval eval _ (fmap eval -> For before cond step body) = forLoop before cond step body - -data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ForEach where liftEq = genericLiftEq -instance Ord1 ForEach where liftCompare = genericLiftCompare -instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for ForEach -instance Evaluatable ForEach - -data While a = While { whileCondition :: !a, whileBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 While where liftEq = genericLiftEq -instance Ord1 While where liftCompare = genericLiftCompare -instance Show1 While where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable While where - eval eval _ While{..} = while (eval whileCondition) (eval whileBody) - -data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 DoWhile where liftEq = genericLiftEq -instance Ord1 DoWhile where liftCompare = genericLiftCompare -instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable DoWhile where - eval eval _ DoWhile{..} = doWhile (eval doWhileBody) (eval doWhileCondition) - --- Exception handling - -newtype Throw a = Throw { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Throw where liftEq = genericLiftEq -instance Ord1 Throw where liftCompare = genericLiftCompare -instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Throw -instance Evaluatable Throw - - -data Try a = Try { tryBody :: !a, tryCatch :: ![a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Try where liftEq = genericLiftEq -instance Ord1 Try where liftCompare = genericLiftCompare -instance Show1 Try where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Try -instance Evaluatable Try - -data Catch a = Catch { catchException :: !a, catchBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Catch where liftEq = genericLiftEq -instance Ord1 Catch where liftCompare = genericLiftCompare -instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Catch -instance Evaluatable Catch - -newtype Finally a = Finally { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Finally where liftEq = genericLiftEq -instance Ord1 Finally where liftCompare = genericLiftCompare -instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Finally -instance Evaluatable Finally - --- Scoping - --- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl). -newtype ScopeEntry a = ScopeEntry { terms :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ScopeEntry where liftEq = genericLiftEq -instance Ord1 ScopeEntry where liftCompare = genericLiftCompare -instance Show1 ScopeEntry where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for ScopeEntry -instance Evaluatable ScopeEntry - - --- | ScopeExit (e.g. `END {}` block in Ruby or Perl). -newtype ScopeExit a = ScopeExit { terms :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ScopeExit where liftEq = genericLiftEq -instance Ord1 ScopeExit where liftCompare = genericLiftCompare -instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for ScopeExit -instance Evaluatable ScopeExit diff --git a/src/Data/Syntax/Type.hs b/src/Data/Syntax/Type.hs deleted file mode 100644 index ec2147f380..0000000000 --- a/src/Data/Syntax/Type.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Syntax.Type (module Data.Syntax.Type) where - -import Data.Abstract.Evaluatable -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import GHC.Generics (Generic1) -import Prelude hiding (Bool, Double, Float, Int) - -data Array a = Array { arraySize :: Maybe a, arrayElementType :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Array where liftEq = genericLiftEq -instance Ord1 Array where liftCompare = genericLiftCompare -instance Show1 Array where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Array -instance Evaluatable Array - - --- TODO: What about type variables? re: FreeVariables1 -data Annotation a = Annotation { annotationSubject :: a, annotationType :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Annotation where liftEq = genericLiftEq -instance Ord1 Annotation where liftCompare = genericLiftCompare -instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec - --- TODO: Specialize Evaluatable for Type to unify the inferred type of the subject with the specified type -instance Evaluatable Annotation where - eval eval _ Annotation{..} = eval annotationSubject - - -data Function a = Function { functionParameters :: [a], functionReturn :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Function where liftEq = genericLiftEq -instance Ord1 Function where liftCompare = genericLiftCompare -instance Show1 Function where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Function -instance Evaluatable Function - - -newtype Interface a = Interface { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Interface where liftEq = genericLiftEq -instance Ord1 Interface where liftCompare = genericLiftCompare -instance Show1 Interface where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Interface -instance Evaluatable Interface - -data Map a = Map { mapKeyType :: a, mapElementType :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Map where liftEq = genericLiftEq -instance Ord1 Map where liftCompare = genericLiftCompare -instance Show1 Map where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Map -instance Evaluatable Map - -newtype Parenthesized a = Parenthesized { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Parenthesized where liftEq = genericLiftEq -instance Ord1 Parenthesized where liftCompare = genericLiftCompare -instance Show1 Parenthesized where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Parenthesized -instance Evaluatable Parenthesized - -newtype Pointer a = Pointer { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Pointer where liftEq = genericLiftEq -instance Ord1 Pointer where liftCompare = genericLiftCompare -instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Pointer -instance Evaluatable Pointer - -newtype Product a = Product { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Product where liftEq = genericLiftEq -instance Ord1 Product where liftCompare = genericLiftCompare -instance Show1 Product where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Product -instance Evaluatable Product - - -data Readonly a = Readonly - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Readonly where liftEq = genericLiftEq -instance Ord1 Readonly where liftCompare = genericLiftCompare -instance Show1 Readonly where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Readonly -instance Evaluatable Readonly - -newtype Slice a = Slice { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Slice where liftEq = genericLiftEq -instance Ord1 Slice where liftCompare = genericLiftCompare -instance Show1 Slice where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Slice -instance Evaluatable Slice - -newtype TypeParameters a = TypeParameters { terms :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeParameters where liftEq = genericLiftEq -instance Ord1 TypeParameters where liftCompare = genericLiftCompare -instance Show1 TypeParameters where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for TypeParameters -instance Evaluatable TypeParameters - --- data instead of newtype because no payload -data Void a = Void - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Void where liftEq = genericLiftEq -instance Ord1 Void where liftCompare = genericLiftCompare -instance Show1 Void where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Void -instance Evaluatable Void - --- data instead of newtype because no payload -data Int a = Int - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Int where liftEq = genericLiftEq -instance Ord1 Int where liftCompare = genericLiftCompare -instance Show1 Int where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Int -instance Evaluatable Int - -data Float a = Float - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Float where liftEq = genericLiftEq -instance Ord1 Float where liftCompare = genericLiftCompare -instance Show1 Float where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Float -instance Evaluatable Float - -data Double a = Double - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Double where liftEq = genericLiftEq -instance Ord1 Double where liftCompare = genericLiftCompare -instance Show1 Double where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Double -instance Evaluatable Double - -data Bool a = Bool - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Bool where liftEq = genericLiftEq -instance Ord1 Bool where liftCompare = genericLiftCompare -instance Show1 Bool where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Float -instance Evaluatable Bool diff --git a/src/Data/Term.hs b/src/Data/Term.hs index 9f96e48f6b..53de9649bc 100644 --- a/src/Data/Term.hs +++ b/src/Data/Term.hs @@ -23,6 +23,8 @@ module Data.Term , injectTerm ) where +-- TODO remove this?? + import Control.Lens.Lens import Data.Bifoldable import Data.Bifunctor diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs deleted file mode 100644 index 5e4ffee881..0000000000 --- a/src/Language/Go/Assignment.hs +++ /dev/null @@ -1,550 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Language.Go.Assignment -( assignment -, Go.Syntax -, Grammar -, Go.Term(..) -) where - -import Analysis.Name (name) -import Assigning.Assignment hiding (Assignment, Error) -import qualified Assigning.Assignment as Assignment -import Control.Monad -import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..)) -import Data.ImportPath () -import Data.ImportPath (defaultAlias, importPath) -import Data.List.NonEmpty (NonEmpty (..), some1) -import Data.Sum -import Data.Syntax - (contextualize, emptyTerm, handleError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1, parseError) -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term -import Language.Go.Grammar as Grammar -import Language.Go.Syntax as Go.Syntax hiding (labelName, runeLiteral) -import Language.Go.Term as Go -import Language.Go.Type as Go.Type - -type Assignment = Assignment.Assignment Grammar - --- | Assignment from AST in Go's grammar onto a program in Go's syntax. -assignment :: Assignment (Term Loc) -assignment = handleError program <|> parseError - -program :: Assignment (Term Loc) -program = makeTerm <$> symbol SourceFile <*> children (Statement.Statements <$> manyTerm expression) - -expression :: Assignment (Term Loc) -expression = term (handleError (choice expressionChoices)) - -expressionChoices :: [Assignment (Term Loc)] -expressionChoices = - [ argumentList - , assignment' - , boolean - , binaryExpression - , block - , breakStatement - , callExpression - , communicationCase - , compositeLiteral - , continueStatement - , varDeclaration - , varSpecification - , decStatement - , defaultCase - , defaultExpressionCase - , deferStatement - , element - , emptyStatement - , expressionCase - , expressionList - , expressionSwitchStatement - , fallThroughStatement - , fieldDeclaration - , fieldDeclarationList - , fieldIdentifier - , floatLiteral - , forStatement - , functionDeclaration - , goStatement - , gotoStatement - , ifStatement - , imaginaryLiteral - , incStatement - , identifier - , importDeclaration - , indexExpression - , interpretedStringLiteral - , intLiteral - , keyedElement - , labelName - , labeledStatement - , literalValue - , methodDeclaration - , methodSpec - , methodSpecList - , nil - , packageClause - , packageIdentifier - , parameterDeclaration - , parameters - , parenthesizedExpression - , rawStringLiteral - , receiveStatement - , returnStatement - , runeLiteral - , selectStatement - , selectorExpression - , sendStatement - , shortVarDeclaration - , sliceExpression - , unaryExpression - , variadicArgument - , variadicParameterDeclaration - , types - ] - -types :: Assignment (Term Loc) -types = - choice [ arrayType - , channelType - , functionType - , implicitLengthArrayType - , interfaceType - , mapType - , parenthesizedType - , pointerType - , qualifiedType - , sliceType - , structType - , typeAssertion - , typeConversion - , typeDeclaration - , typeIdentifier - , typeCase - , typeSwitchStatement - ] - -identifiers :: Assignment (Term Loc) -identifiers = makeTerm'' <$> location <*> manyTerm identifier - -expressions :: Assignment (Term Loc) -expressions = makeTerm'' <$> location <*> manyTerm expression - - --- Literals - -comment :: Assignment (Term Loc) -comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) - -compositeLiteral :: Assignment (Term Loc) -compositeLiteral = makeTerm <$> symbol CompositeLiteral <*> children (Go.Syntax.Composite <$> expression <*> expression) - -element :: Assignment (Term Loc) -element = symbol Element *> children expression - -fieldIdentifier :: Assignment (Term Loc) -fieldIdentifier = makeTerm <$> symbol FieldIdentifier <*> (Syntax.Identifier . name <$> source) - -floatLiteral :: Assignment (Term Loc) -floatLiteral = makeTerm <$> symbol FloatLiteral <*> (Literal.Float <$> source) - -identifier :: Assignment (Term Loc) -identifier = makeTerm <$> (symbol Identifier <|> symbol Identifier' <|> symbol Identifier'') <*> (Syntax.Identifier . name <$> source) - -imaginaryLiteral :: Assignment (Term Loc) -imaginaryLiteral = makeTerm <$> symbol ImaginaryLiteral <*> (Literal.Complex <$> source) - -interpretedStringLiteral :: Assignment (Term Loc) -interpretedStringLiteral = makeTerm' <$> symbol InterpretedStringLiteral <*> children ( (inject . Literal.String <$> some escapeSequence) - <|> (inject . Literal.TextElement <$> source)) - -escapeSequence :: Assignment (Term Loc) -escapeSequence = makeTerm <$> symbol EscapeSequence <*> (Literal.EscapeSequence <$> source) - -intLiteral :: Assignment (Term Loc) -intLiteral = makeTerm <$> symbol IntLiteral <*> (Literal.Integer <$> source) - -literalValue :: Assignment (Term Loc) -literalValue = makeTerm <$> symbol LiteralValue <*> children (manyTerm expression) - -packageIdentifier :: Assignment (Term Loc) -packageIdentifier = makeTerm <$> symbol PackageIdentifier <*> (Syntax.Identifier . name <$> source) - -parenthesizedType :: Assignment (Term Loc) -parenthesizedType = makeTerm <$> symbol Grammar.ParenthesizedType <*> children (Type.Parenthesized <$> expression) - -rawStringLiteral :: Assignment (Term Loc) -rawStringLiteral = makeTerm <$> symbol RawStringLiteral <*> (Literal.TextElement <$> source) - -runeLiteral :: Assignment (Term Loc) -runeLiteral = makeTerm <$> symbol Grammar.RuneLiteral <*> (Go.Syntax.Rune <$> source) - -typeIdentifier :: Assignment (Term Loc) -typeIdentifier = makeTerm <$> symbol TypeIdentifier <*> (Syntax.Identifier . name <$> source) - -nil :: Assignment (Term Loc) -nil = makeTerm <$> symbol Nil <*> (Literal.Null <$ source) - -boolean :: Assignment (Term Loc) -boolean = makeTerm <$> token Grammar.True <*> pure Literal.true - <|> makeTerm <$> token Grammar.False <*> pure Literal.false - - --- Primitive Types - -arrayType :: Assignment (Term Loc) -arrayType = makeTerm <$> symbol ArrayType <*> children (Type.Array . Just <$> expression <*> expression) - -channelType :: Assignment (Term Loc) -channelType = makeTerm' <$> symbol ChannelType <*> children (mkChannelType <$> optional (token AnonLAngleMinus) <* token AnonChan <*> optional (token AnonLAngleMinus) <*> expression) - where - mkChannelType :: Maybe a -> Maybe a -> b -> Sum Go.Syntax b - mkChannelType receive send | Just _ <- receive = inject . Go.Type.ReceiveChannel - | Just _ <- send = inject . Go.Type.SendChannel - | otherwise = inject . Go.Type.BidirectionalChannel - -fieldDeclaration :: Assignment (Term Loc) -fieldDeclaration = mkFieldDeclarationWithTag <$> symbol FieldDeclaration <*> children ((,,) <$> (manyTermsTill expression (void (symbol TypeIdentifier)) <|> manyTerm expression) <*> optional expression <*> optional expression) - where - mkFieldDeclarationWithTag loc (fields, type', tag) | Just ty <- type', Just tag' <- tag = makeTerm loc (Go.Syntax.Field [ty, tag'] (makeTerm loc fields)) - | Just ty <- type' = makeTerm loc (Go.Syntax.Field [ty] (makeTerm loc fields)) - | Just tag' <- tag = makeTerm loc (Go.Syntax.Field [tag'] (makeTerm loc fields)) - | otherwise = makeTerm loc (Go.Syntax.Field [] (makeTerm loc fields)) - -fieldDeclarationList :: Assignment (Term Loc) -fieldDeclarationList = symbol FieldDeclarationList *> children expressions - -functionType :: Assignment (Term Loc) -functionType = makeTerm <$> symbol FunctionType <*> children (Type.Function <$> params <*> (expression <|> emptyTerm)) - where params = symbol ParameterList *> children (manyTerm expression) - -implicitLengthArrayType :: Assignment (Term Loc) -implicitLengthArrayType = makeTerm <$> symbol ImplicitLengthArrayType <*> children (Type.Array Nothing <$> expression) - -interfaceType :: Assignment (Term Loc) -interfaceType = makeTerm <$> symbol InterfaceType <*> children (Type.Interface <$> manyTerm expression) - -mapType :: Assignment (Term Loc) -mapType = makeTerm <$> symbol MapType <*> children (Type.Map <$> expression <*> expression) - -pointerType :: Assignment (Term Loc) -pointerType = makeTerm <$> symbol PointerType <*> children (Type.Pointer <$> expression) - -qualifiedType :: Assignment (Term Loc) -qualifiedType = makeTerm <$> symbol QualifiedType <*> children (Expression.MemberAccess <$> expression <*> typeIdentifier) - -sliceType :: Assignment (Term Loc) -sliceType = makeTerm <$> symbol SliceType <*> children (Type.Slice <$> expression) - -structType :: Assignment (Term Loc) -structType = makeTerm <$> symbol StructType <*> children (Declaration.Constructor [] <$> emptyTerm <*> expressions) - -typeAlias :: Assignment (Term Loc) -typeAlias = makeTerm <$> symbol TypeAlias <*> children (Declaration.TypeAlias [] <$> expression <*> expression) - -typeDeclaration :: Assignment (Term Loc) -typeDeclaration = makeTerm <$> symbol TypeDeclaration <*> children (manyTerm ( (makeTerm <$> symbol TypeSpec <*> children (Declaration.Type <$> typeIdentifier <*> expression)) - <|> typeAlias )) - - - --- Expressions - -argumentList :: Assignment (Term Loc) -argumentList = (symbol ArgumentList <|> symbol ArgumentList') *> children expressions - -binaryExpression :: Assignment (Term Loc) -binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression expression - [ (inject .) . Expression.Plus <$ symbol AnonPlus - , (inject .) . Expression.Minus <$ symbol AnonMinus - , (inject .) . Expression.Times <$ symbol AnonStar - , (inject .) . Expression.DividedBy <$ symbol AnonSlash - , (inject .) . Expression.Modulo <$ symbol AnonPercent - , (inject .) . Expression.Or <$ symbol AnonPipePipe - , (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand - , (inject .) . Expression.LessThan <$ symbol AnonLAngle - , (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual - , (inject .) . Expression.GreaterThan <$ symbol AnonRAngle - , (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual - , (inject .) . invert Expression.Equal <$ symbol AnonBangEqual - , (inject .) . Expression.Equal <$ symbol AnonEqualEqual - , (inject .) . Expression.BOr <$ symbol AnonPipe - , (inject .) . Expression.BAnd <$ symbol AnonAmpersand - , (inject .) . Expression.BAnd <$ symbol AnonAmpersandCaret - , (inject .) . Expression.BXOr <$ symbol AnonCaret - , (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle - , (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle - ]) - where - invert cons a b = Expression.Not (makeTerm1 (cons a b)) - -block :: Assignment (Term Loc) -block = symbol Block *> children expressions - -defaultCase :: Assignment (Term Loc) -defaultCase = makeTerm <$> symbol DefaultCase <*> children (Go.Syntax.DefaultPattern <$> (expressions <|> emptyTerm)) - -defaultExpressionCase :: Assignment (Term Loc) -defaultExpressionCase = makeTerm <$> symbol DefaultCase <*> children (Go.Syntax.DefaultPattern <$> (expressions <|> emptyTerm)) - -callExpression :: Assignment (Term Loc) -callExpression = makeTerm <$> symbol CallExpression <*> children (Expression.Call [] <$> expression <*> manyTerm expression <*> emptyTerm) - -expressionCase :: Assignment (Term Loc) -expressionCase = makeTerm <$> symbol ExpressionCase <*> (Statement.Pattern <$> children expressions <*> expressions) - -expressionList :: Assignment (Term Loc) -expressionList = symbol ExpressionList *> children expressions - -expressionSwitchStatement :: Assignment (Term Loc) -expressionSwitchStatement - = makeTerm - <$> symbol ExpressionSwitchStatement - <*> children (Statement.Match <$> (makeTerm <$> location <*> manyTermsTill expression (void (symbol ExpressionCase)) <|> emptyTerm) <*> expressions) - -fallThroughStatement :: Assignment (Term Loc) -fallThroughStatement = makeTerm <$> symbol FallthroughStatement <*> (Statement.Pattern <$> (makeTerm <$> location <*> (Syntax.Identifier . name <$> source)) <*> emptyTerm) - -functionDeclaration :: Assignment (Term Loc) -functionDeclaration = makeTerm <$> (symbol FunctionDeclaration <|> symbol FuncLiteral) <*> children (mkFunctionDeclaration <$> (term identifier <|> emptyTerm) <*> params <*> returnTypes <*> (term block <|> emptyTerm)) - where - returnTypes = pure <$> (term types <|> term identifier <|> term returnParameters) - <|> pure [] - params = symbol ParameterList *> children (manyTerm expression) - mkFunctionDeclaration name' params' types' block' = Declaration.Function types' name' params' block' - returnParameters = makeTerm <$> symbol ParameterList <*> children (manyTerm expression) - -importDeclaration :: Assignment (Term Loc) -importDeclaration = makeTerm'' <$> symbol ImportDeclaration <*> children (manyTerm (importSpec <|> importSpecList)) - where - -- `import . "lib/Math"` - dotImport = inject <$> (flip Go.Syntax.Import <$> dot <*> importFromPath) - -- `import _ "lib/Math"` - sideEffectImport = inject <$> (flip Go.Syntax.SideEffectImport <$> underscore <*> importFromPath) - -- `import m "lib/Math"` - namedImport = inject <$> (flip Go.Syntax.QualifiedImport <$> packageIdentifier <*> importFromPath) - -- `import "lib/Math"` - plainImport = inject <$> (symbol InterpretedStringLiteral >>= \loc -> do - from <- importPath <$> source - let alias = makeTerm loc (Syntax.Identifier (defaultAlias from)) -- Go takes `import "lib/Math"` and uses `Math` as the qualified name (e.g. `Math.Sin()`) - pure $! Go.Syntax.QualifiedImport from alias) - interpretedStringLiteral' = symbol InterpretedStringLiteral *> children ( (inject . Literal.String <$> some escapeSequence) - <|> (inject . Literal.TextElement <$> source)) - rawStringLiteral' = symbol RawStringLiteral *> (inject . Literal.TextElement <$> source) - dot = makeTerm <$> symbol Dot <*> (Literal.TextElement <$> source) - underscore = makeTerm <$> symbol BlankIdentifier <*> (Literal.TextElement <$> source) - importSpec = makeTerm' <$> symbol ImportSpec <*> children (sideEffectImport <|> dotImport <|> namedImport <|> plainImport <|> interpretedStringLiteral' <|> rawStringLiteral') - importSpecList = makeTerm <$> symbol ImportSpecList <*> children (manyTerm (importSpec <|> comment)) - importFromPath = symbol InterpretedStringLiteral *> (importPath <$> source) - -indexExpression :: Assignment (Term Loc) -indexExpression = makeTerm <$> symbol IndexExpression <*> children (Expression.Subscript <$> expression <*> manyTerm expression) - -methodDeclaration :: Assignment (Term Loc) -methodDeclaration = makeTerm <$> symbol MethodDeclaration <*> children (mkTypedMethodDeclaration <$> receiver <*> pure publicAccessControl <*> term fieldIdentifier <*> params <*> returnParameters <*> (term block <|> emptyTerm)) - where - params = symbol ParameterList *> children (manyTerm expression) - receiver = symbol ParameterList *> children expressions - mkTypedMethodDeclaration receiver' accessControl name' parameters' type'' body' = Declaration.Method type'' receiver' name' parameters' body' accessControl - returnParameters = (symbol ParameterList *> children (manyTerm expression)) - <|> pure <$> expression - <|> pure [] - -methodSpec :: Assignment (Term Loc) -methodSpec = makeTerm <$> symbol MethodSpec <*> children (mkMethodSpec publicAccessControl <$> expression <*> params <*> (expression <|> emptyTerm)) - where - params = symbol ParameterList *> children (manyTerm expression) - mkMethodSpec accessControl name' params optionalTypeLiteral = Declaration.MethodSignature [optionalTypeLiteral] name' params accessControl - -publicAccessControl :: ScopeGraph.AccessControl -publicAccessControl = ScopeGraph.Public - -methodSpecList :: Assignment (Term Loc) -methodSpecList = symbol MethodSpecList *> children expressions - -packageClause :: Assignment (Term Loc) -packageClause = makeTerm <$> symbol PackageClause <*> children (Go.Syntax.Package <$> expression <*> pure []) - -parameters :: Assignment (Term Loc) -parameters = symbol ParameterList *> children expressions - -parameterDeclaration :: Assignment (Term Loc) -parameterDeclaration = makeTerm <$> symbol ParameterDeclaration <*> children (manyTerm expression) - -parenthesizedExpression :: Assignment (Term Loc) -parenthesizedExpression = symbol ParenthesizedExpression *> children expressions - -selectorExpression :: Assignment (Term Loc) -selectorExpression = makeWithContext <$> symbol SelectorExpression <*> children ((,,) <$> expression <*> optional comment <*> fieldIdentifier) - where makeWithContext loc (lhs, comment, rhs) = maybe (makeTerm loc (Expression.MemberAccess lhs rhs)) (\c -> makeTerm loc (Syntax.Context (c :| []) (makeTerm loc (Expression.MemberAccess lhs rhs)))) comment - -sliceExpression :: Assignment (Term Loc) -sliceExpression = makeTerm <$> symbol SliceExpression <*> children (Go.Syntax.Slice <$> expression <* token AnonLBracket <*> (emptyTerm <|> expression) <* token AnonColon <*> (expression <|> emptyTerm) <* optional (token AnonColon) <*> (expression <|> emptyTerm)) - -typeAssertion :: Assignment (Term Loc) -typeAssertion = makeTerm <$> symbol TypeAssertionExpression <*> children (Go.Syntax.TypeAssertion <$> expression <*> expression) - -typeCase :: Assignment (Term Loc) -typeCase = symbol TypeCase *> children expressions - -typeConversion :: Assignment (Term Loc) -typeConversion = makeTerm <$> symbol TypeConversionExpression <*> children (Go.Syntax.TypeConversion <$> expression <*> expression) - -typeSwitchStatement :: Assignment (Term Loc) -typeSwitchStatement = makeTerm <$> symbol TypeSwitchStatement <*> children (Go.Syntax.TypeSwitch <$> typeSwitchSubject <*> expressions) - where - typeSwitchSubject = makeTerm <$> location <*> manyTermsTill expression (void (symbol TypeCase)) <|> emptyTerm - -unaryExpression :: Assignment (Term Loc) -unaryExpression = makeTerm' <$> symbol UnaryExpression <*> ( notExpression - <|> unaryMinus - <|> unaryAmpersand - <|> unaryReceive - <|> unaryPointer - <|> unaryComplement - <|> unaryPlus ) - where - notExpression = inject <$> children (Expression.Not <$ symbol AnonBang <*> expression) - unaryAmpersand = inject <$> children (Literal.Reference <$ symbol AnonAmpersand <*> expression) - unaryComplement = inject <$> children (Expression.Complement <$ symbol AnonCaret <*> expression) - unaryMinus = inject <$> children (Expression.Negate <$ symbol AnonMinus <*> expression) - unaryPlus = children (symbol AnonPlus *> (Term.termOut <$> expression)) - unaryPointer = inject <$> children (Literal.Pointer <$ symbol AnonStar <*> expression) - unaryReceive = inject <$> children (Go.Syntax.ReceiveOperator <$ symbol AnonLAngleMinus <*> expression) - -varDeclaration :: Assignment (Term Loc) -varDeclaration = (symbol ConstDeclaration <|> symbol VarDeclaration) *> children expressions - -variadicArgument :: Assignment (Term Loc) -variadicArgument = makeTerm <$> symbol VariadicArgument <*> children (Go.Syntax.Variadic [] <$> expressions) - -variadicParameterDeclaration :: Assignment (Term Loc) -variadicParameterDeclaration = makeTerm <$> symbol VariadicParameterDeclaration <*> children (flip Go.Syntax.Variadic <$> (expression <|> emptyTerm) <* token AnonDotDotDot <*> many expression) - -varSpecification :: Assignment (Term Loc) -varSpecification = makeTerm <$> (symbol ConstSpec <|> symbol VarSpec) <*> children (Statement.Assignment [] <$> (annotatedLHS <|> identifiers) <*> expressions) - where - annotatedLHS = makeTerm <$> location <*> (Type.Annotation <$> (makeTerm <$> location <*> manyTermsTill identifier (void (symbol TypeIdentifier))) <*> expression) - - --- Statements - -assignment' :: Assignment (Term Loc) -assignment' = makeTerm' <$> symbol AssignmentStatement <*> children (infixTerm expressionList expressionList - [ assign <$ symbol AnonEqual - , augmentedAssign Expression.Plus <$ symbol AnonPlusEqual - , augmentedAssign Expression.Minus <$ symbol AnonMinusEqual - , augmentedAssign Expression.Times <$ symbol AnonStarEqual - , augmentedAssign Expression.DividedBy <$ symbol AnonSlashEqual - , augmentedAssign Expression.BOr <$ symbol AnonPipeEqual - , augmentedAssign Expression.BAnd <$ symbol AnonAmpersandEqual - , augmentedAssign Expression.Modulo <$ symbol AnonPercentEqual - , augmentedAssign Expression.RShift <$ symbol AnonRAngleRAngleEqual - , augmentedAssign Expression.LShift <$ symbol AnonLAngleLAngleEqual - , augmentedAssign Expression.BXOr <$ symbol AnonCaretEqual - , augmentedAssign (invert Expression.BAnd) <$ symbol AnonAmpersandCaretEqual - ]) - where - assign :: Term Loc -> Term Loc -> Sum Go.Syntax (Term Loc) - assign l r = inject (Statement.Assignment [] l r) - - augmentedAssign :: (f :< Go.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum Go.Syntax (Term Loc) - augmentedAssign c l r = inject (Statement.AugmentedAssignment (makeTerm1 (c l r))) - - invert cons a b = Expression.Not (makeTerm1 (cons a b)) - -breakStatement :: Assignment (Term Loc) -breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (expression <|> emptyTerm)) - -communicationCase :: Assignment (Term Loc) -communicationCase = makeTerm <$> symbol CommunicationCase <*> children (Statement.Pattern <$> expression <*> expressions) - -continueStatement :: Assignment (Term Loc) -continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (expression <|> emptyTerm)) - -decStatement :: Assignment (Term Loc) -decStatement = makeTerm <$> symbol DecStatement <*> children (Statement.PostDecrement <$> expression) - -deferStatement :: Assignment (Term Loc) -deferStatement = makeTerm <$> symbol DeferStatement <*> children (Go.Syntax.Defer <$> expression) - -emptyStatement :: Assignment (Term Loc) -emptyStatement = makeTerm <$> token EmptyStatement <*> (Statement.NoOp <$> emptyTerm) - -forStatement :: Assignment (Term Loc) -forStatement = makeTerm' <$> symbol ForStatement <*> children (forClause <|> forSimpleClause <|> rangeClause) - where - forClause = inject <$> (symbol ForClause *> children (Statement.For <$> (expression <|> emptyTerm) <*> (expression <|> emptyTerm) <*> (expression <|> emptyTerm)) <*> expression) - forSimpleClause = inject <$> (Statement.For <$> emptyTerm <*> (expression <|> emptyTerm) <*> emptyTerm <*> expression) - rangeClause = inject <$> (symbol RangeClause *> children (Statement.ForEach <$> (expression <|> emptyTerm) <*> expression) <*> expression) - -goStatement :: Assignment (Term Loc) -goStatement = makeTerm <$> symbol GoStatement <*> children (Go.Syntax.Go <$> expression) - -gotoStatement :: Assignment (Term Loc) -gotoStatement = makeTerm <$> symbol GotoStatement <*> children (Statement.Goto <$> expression) - -ifStatement :: Assignment (Term Loc) -ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> (makeTerm <$> location <*> manyTermsTill expression (void (symbol Block))) <*> expression <*> (expression <|> emptyTerm)) - -incStatement :: Assignment (Term Loc) -incStatement = makeTerm <$> symbol IncStatement <*> children (Statement.PostIncrement <$> expression) - -keyedElement :: Assignment (Term Loc) -keyedElement = makeTerm <$> symbol KeyedElement <*> children (Literal.KeyValue <$> expression <*> expression) - -labelName :: Assignment (Term Loc) -labelName = makeTerm <$> symbol LabelName <*> (Syntax.Identifier . name <$> source) - -labeledStatement :: Assignment (Term Loc) -labeledStatement = makeTerm <$> (symbol LabeledStatement <|> symbol LabeledStatement') <*> children (Go.Syntax.Label <$> expression <*> (expression <|> emptyTerm)) - -returnStatement :: Assignment (Term Loc) -returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (expression <|> emptyTerm)) - -receiveStatement :: Assignment (Term Loc) -receiveStatement = makeTerm <$> symbol ReceiveStatement <*> children (Go.Syntax.Receive <$> (expression <|> emptyTerm) <*> expression) - -shortVarDeclaration :: Assignment (Term Loc) -shortVarDeclaration = makeTerm <$> symbol ShortVarDeclaration <*> children (Statement.Assignment [] <$> expression <*> expression) - -selectStatement :: Assignment (Term Loc) -selectStatement = makeTerm <$> symbol SelectStatement <*> children (Go.Syntax.Select <$> expressions) - -sendStatement :: Assignment (Term Loc) -sendStatement = makeTerm <$> symbol SendStatement <*> children (Go.Syntax.Send <$> expression <*> expression) - - --- Helpers - --- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment (Term Loc) - -> Assignment (Term Loc) - -> [Assignment (Term Loc -> Term Loc -> Sum Go.Syntax (Term Loc))] - -> Assignment (Sum Go.Syntax (Term Loc)) -infixTerm = infixContext comment - --- | Match a series of terms or comments until a delimiter is matched -manyTermsTill :: Assignment (Term Loc) - -> Assignment b - -> Assignment [Term Loc] -manyTermsTill step end = manyTill (step <|> comment) end - --- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] -manyTerm = many . term - --- | Match a term and contextualize any comments preceding or proceeding the term. -term :: Assignment (Term Loc) -> Assignment (Term Loc) -term term' = contextualize comment term' <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm) diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs deleted file mode 100644 index aba5611c21..0000000000 --- a/src/Language/Go/Syntax.hs +++ /dev/null @@ -1,325 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -module Language.Go.Syntax (module Language.Go.Syntax) where - -import Control.Abstract -import Data.Abstract.BaseError -import Data.Abstract.Evaluatable -import Data.Abstract.Module -import qualified Data.Abstract.Package as Package -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Foldable -import Data.Abstract.Path -import Data.Functor.Classes -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import Data.ImportPath -import Data.List.NonEmpty (nonEmpty) -import qualified Data.Map as Map -import Data.Semigroup.App -import Data.Semigroup.Foldable -import Data.Text (Text) -import qualified Data.Text as T -import GHC.Generics (Generic1) -import qualified System.Path as Path -import System.FilePath.Posix - - -resolveGoImport :: ( Has (Modules address value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Package.PackageInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - , Has Trace sig m - ) - => ImportPath - -> Evaluator term address value m [ModulePath] -resolveGoImport (ImportPath path Data.ImportPath.Unknown) = throwResolutionError $ GoImportError path -resolveGoImport (ImportPath path Relative) = do - ModuleInfo{..} <- currentModule - paths <- listModulesInDir $ (joinPaths (Path.takeDirectory modulePath) (Path.rel path)) - case paths of - [] -> throwResolutionError $ GoImportError path - _ -> pure paths -resolveGoImport (ImportPath path NonRelative) = do - package <- T.unpack . formatName . Package.packageName <$> currentPackage - trace ("attempting to resolve " <> show path <> " for package " <> package) - case splitDirectories path of - -- Import an absolute path that's defined in this package being analyzed. - -- First two are source, next is package name, remaining are path to package - -- (e.g. github.com/golang//path...). - (_ : _ : p : xs) | p == package -> listModulesInDir (Path.toAbsRel $ Path.joinPath xs) - _ -> throwResolutionError $ GoImportError path - --- | Import declarations (symbols are added directly to the calling environment). --- --- If the list of symbols is empty copy everything to the calling environment. -data Import a = Import { importFrom :: ImportPath, importWildcardToken :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Import where liftEq = genericLiftEq -instance Ord1 Import where liftCompare = genericLiftCompare -instance Show1 Import where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Import where - eval _ _ (Language.Go.Syntax.Import importPath _) = do - paths <- resolveGoImport importPath - for_ paths $ \path -> do - traceResolve (unPath importPath) path - ((moduleScope, moduleFrame), _) <- require path - insertImportEdge moduleScope - insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - unit - - --- | Qualified Import declarations (symbols are qualified in calling environment). --- --- If the list of symbols is empty copy and qualify everything to the calling environment. -data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, qualifiedImportAlias :: !a} - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 QualifiedImport where liftEq = genericLiftEq -instance Ord1 QualifiedImport where liftCompare = genericLiftCompare -instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QualifiedImport where - eval _ _ (QualifiedImport importPath aliasTerm) = do - paths <- resolveGoImport importPath - span <- ask @Span - scopeAddress <- newScope mempty - name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress) - aliasSlot <- lookupSlot (Declaration name) - - withScope scopeAddress $ do - let - go [] = pure () - go (modulePath : paths) = - mkScopeMap modulePath (\scopeMap -> do - objFrame <- newFrame scopeAddress (Map.singleton ScopeGraph.Import scopeMap) - val <- object objFrame - assign aliasSlot val - for_ paths $ \modulePath -> - mkScopeMap modulePath (withFrame objFrame . insertFrameLink ScopeGraph.Import)) - where mkScopeMap modulePath fun = do - ((moduleScope, moduleFrame), _) <- require modulePath - insertImportEdge moduleScope - fun (Map.singleton moduleScope moduleFrame) - go paths - unit - --- | Side effect only imports (no symbols made available to the calling environment). -data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 SideEffectImport where liftEq = genericLiftEq -instance Ord1 SideEffectImport where liftCompare = genericLiftCompare -instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec - --- TODO: Revisit this and confirm if this is correct. -instance Evaluatable SideEffectImport where - eval _ _ (SideEffectImport importPath _) = do - paths <- resolveGoImport importPath - traceResolve (unPath importPath) paths - for_ paths $ \path -> require path -- Do we need to construct any scope / frames for these side-effect imports? - unit - --- A composite literal in Go -data Composite a = Composite { compositeType :: !a, compositeElement :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Composite where liftEq = genericLiftEq -instance Ord1 Composite where liftCompare = genericLiftCompare -instance Show1 Composite where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Composite -instance Evaluatable Composite - --- | A default pattern in a Go select or switch statement (e.g. `switch { default: s() }`). -newtype DefaultPattern a = DefaultPattern { defaultPatternBody :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 DefaultPattern where liftEq = genericLiftEq -instance Ord1 DefaultPattern where liftCompare = genericLiftCompare -instance Show1 DefaultPattern where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for DefaultPattern -instance Evaluatable DefaultPattern - --- | A defer statement in Go (e.g. `defer x()`). -newtype Defer a = Defer { deferBody :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Defer where liftEq = genericLiftEq -instance Ord1 Defer where liftCompare = genericLiftCompare -instance Show1 Defer where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Defer -instance Evaluatable Defer - --- | A go statement (i.e. go routine) in Go (e.g. `go x()`). -newtype Go a = Go { goBody :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Go where liftEq = genericLiftEq -instance Ord1 Go where liftCompare = genericLiftCompare -instance Show1 Go where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Go -instance Evaluatable Go - --- | A label statement in Go (e.g. `label:continue`). -data Label a = Label { labelName :: !a, labelStatement :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Label where liftEq = genericLiftEq -instance Ord1 Label where liftCompare = genericLiftCompare -instance Show1 Label where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Label -instance Evaluatable Label - --- | A rune literal in Go (e.g. `'⌘'`). -newtype Rune a = Rune { runeLiteral :: Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Rune where liftEq = genericLiftEq -instance Ord1 Rune where liftCompare = genericLiftCompare -instance Show1 Rune where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Rune -instance Evaluatable Rune - --- | A select statement in Go (e.g. `select { case x := <-c: x() }` where each case is a send or receive operation on channels). -newtype Select a = Select { selectCases :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Select where liftEq = genericLiftEq -instance Ord1 Select where liftCompare = genericLiftCompare -instance Show1 Select where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Select -instance Evaluatable Select - --- | A send statement in Go (e.g. `channel <- value`). -data Send a = Send { sendReceiver :: !a, sendValue :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Send where liftEq = genericLiftEq -instance Ord1 Send where liftCompare = genericLiftCompare -instance Show1 Send where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Send -instance Evaluatable Send - --- | A slice expression in Go (e.g. `a[1:4:3]` where a is a list, 1 is the low bound, 4 is the high bound, and 3 is the max capacity). -data Slice a = Slice { sliceName :: !a, sliceLow :: !a, sliceHigh :: !a, sliceCapacity :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Slice where liftEq = genericLiftEq -instance Ord1 Slice where liftCompare = genericLiftCompare -instance Show1 Slice where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Slice -instance Evaluatable Slice - --- | A type switch statement in Go (e.g. `switch x.(type) { // cases }`). -data TypeSwitch a = TypeSwitch { typeSwitchSubject :: !a, typeSwitchCases :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeSwitch where liftEq = genericLiftEq -instance Ord1 TypeSwitch where liftCompare = genericLiftCompare -instance Show1 TypeSwitch where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for TypeSwitch -instance Evaluatable TypeSwitch - --- | A type switch guard statement in a Go type switch statement (e.g. `switch i := x.(type) { // cases}`). -newtype TypeSwitchGuard a = TypeSwitchGuard { typeSwitchGuardSubject :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeSwitchGuard where liftEq = genericLiftEq -instance Ord1 TypeSwitchGuard where liftCompare = genericLiftCompare -instance Show1 TypeSwitchGuard where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for TypeSwitchGuard -instance Evaluatable TypeSwitchGuard - --- | A receive statement in a Go select statement (e.g. `case value := <-channel` ) -data Receive a = Receive { receiveSubject :: !a, receiveExpression :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Receive where liftEq = genericLiftEq -instance Ord1 Receive where liftCompare = genericLiftCompare -instance Show1 Receive where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Receive -instance Evaluatable Receive - --- | A receive operator unary expression in Go (e.g. `<-channel` ) -newtype ReceiveOperator a = ReceiveOperator { value :: a} - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ReceiveOperator where liftEq = genericLiftEq -instance Ord1 ReceiveOperator where liftCompare = genericLiftCompare -instance Show1 ReceiveOperator where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for ReceiveOperator -instance Evaluatable ReceiveOperator - --- | A field declaration in a Go struct type declaration. -data Field a = Field { fieldContext :: ![a], fieldName :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Field where liftEq = genericLiftEq -instance Ord1 Field where liftCompare = genericLiftCompare -instance Show1 Field where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Field -instance Evaluatable Field - -data Package a = Package { packageName :: !a, packageContents :: ![a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Package where liftEq = genericLiftEq -instance Ord1 Package where liftCompare = genericLiftCompare -instance Show1 Package where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Package where - eval eval _ (Package _ xs) = maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty xs) - --- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`). -data TypeAssertion a = TypeAssertion { typeAssertionSubject :: !a, typeAssertionType :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeAssertion where liftEq = genericLiftEq -instance Ord1 TypeAssertion where liftCompare = genericLiftCompare -instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for TypeAssertion -instance Evaluatable TypeAssertion - --- | A type conversion expression in Go (e.g. `T(x)` where `T` is a type and `x` is an expression that can be converted to type `T`). -data TypeConversion a = TypeConversion { typeConversionType :: !a, typeConversionSubject :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeConversion where liftEq = genericLiftEq -instance Ord1 TypeConversion where liftCompare = genericLiftCompare -instance Show1 TypeConversion where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for TypeConversion -instance Evaluatable TypeConversion - --- | Variadic arguments and parameters in Go (e.g. parameter: `param ...Type`, argument: `Type...`). -data Variadic a = Variadic { variadicContext :: [a], variadicIdentifier :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Variadic where liftEq = genericLiftEq -instance Ord1 Variadic where liftCompare = genericLiftCompare -instance Show1 Variadic where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Variadic -instance Evaluatable Variadic diff --git a/src/Language/Go/Term.hs b/src/Language/Go/Term.hs deleted file mode 100644 index 0305ac278d..0000000000 --- a/src/Language/Go/Term.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, RecordWildCards, TypeFamilies #-} -module Language.Go.Term -( Syntax -, Term(..) -) where - -import Control.Lens.Lens -import Data.Abstract.Declarations -import Data.Abstract.FreeVariables -import Data.Bitraversable -import Data.Coerce -import Data.Foldable (fold) -import Data.Functor.Foldable (Base, Recursive(..)) -import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) -import qualified Data.Sum as Sum -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term -import Data.Traversable -import Language.Go.Syntax as Go.Syntax -import Language.Go.Type as Go.Type -import Source.Loc -import Source.Span - -type Syntax = - [ Comment.Comment - , Declaration.Constructor - , Declaration.Function - , Declaration.Method - , Declaration.MethodSignature - , Declaration.Type - , Declaration.TypeAlias - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BOr - , Expression.BAnd - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.UnsignedRShift - , Expression.Complement - , Expression.Call - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Subscript - , Expression.Member - , Statement.PostDecrement - , Statement.PostIncrement - , Expression.MemberAccess - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Go.Syntax.Composite - , Go.Syntax.DefaultPattern - , Go.Syntax.Defer - , Go.Syntax.Field - , Go.Syntax.Go - , Go.Syntax.Label - , Go.Syntax.Package - , Go.Syntax.Receive - , Go.Syntax.ReceiveOperator - , Go.Syntax.Rune - , Go.Syntax.Select - , Go.Syntax.Send - , Go.Syntax.Slice - , Go.Syntax.TypeAssertion - , Go.Syntax.TypeConversion - , Go.Syntax.TypeSwitch - , Go.Syntax.TypeSwitchGuard - , Go.Syntax.Variadic - , Go.Type.BidirectionalChannel - , Go.Type.ReceiveChannel - , Go.Type.SendChannel - , Go.Syntax.Import - , Go.Syntax.QualifiedImport - , Go.Syntax.SideEffectImport - , Literal.Array - , Literal.Complex - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.KeyValue - , Literal.Pointer - , Literal.Reference - , Literal.TextElement - , Statement.Assignment - , Statement.AugmentedAssignment - , Statement.Break - , Statement.Continue - , Statement.For - , Statement.ForEach - , Statement.Goto - , Statement.If - , Statement.Match - , Statement.NoOp - , Statement.Pattern - , Statement.Return - , Statement.Statements - , Syntax.Context - , Syntax.Error - , Syntax.Empty - , Syntax.Identifier - , Type.Annotation - , Type.Array - , Type.Function - , Type.Interface - , Type.Map - , Type.Parenthesized - , Type.Pointer - , Type.Slice - , [] - , Literal.String - , Literal.EscapeSequence - , Literal.Null - , Literal.Boolean - ] - - -newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } - deriving (Eq, Declarations, FreeVariables, Ord, Show) - -instance Term.IsTerm Term where - type Syntax Term = Sum.Sum Syntax - toTermF = coerce - fromTermF = coerce - -instance Foldable Term where - foldMap = foldMapDefault - -instance Functor Term where - fmap = fmapDefault - -instance Traversable Term where - traverse f = go where go = fmap Term . bitraverse f go . getTerm - -instance VertexDeclaration Term where - toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax - -instance Syntax.HasErrors Term where - getErrors = cata $ \ (Term.In Loc{..} syntax) -> - maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) - - -type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann - -instance Recursive (Term ann) where - project = getTerm - -instance HasSpan ann => HasSpan (Term ann) where - span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) - {-# INLINE span_ #-} diff --git a/src/Language/Go/Type.hs b/src/Language/Go/Type.hs deleted file mode 100644 index 788dbaac1d..0000000000 --- a/src/Language/Go/Type.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -module Language.Go.Type (module Language.Go.Type) where - -import Data.Abstract.Evaluatable -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import GHC.Generics (Generic1) - --- | A Bidirectional channel in Go (e.g. `chan`). -newtype BidirectionalChannel a = BidirectionalChannel { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 BidirectionalChannel where liftEq = genericLiftEq -instance Ord1 BidirectionalChannel where liftCompare = genericLiftCompare -instance Show1 BidirectionalChannel where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for BidirectionalChannel -instance Evaluatable BidirectionalChannel - --- | A Receive channel in Go (e.g. `<-chan`). -newtype ReceiveChannel a = ReceiveChannel { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ReceiveChannel where liftEq = genericLiftEq -instance Ord1 ReceiveChannel where liftCompare = genericLiftCompare -instance Show1 ReceiveChannel where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for ReceiveChannel -instance Evaluatable ReceiveChannel - --- | A Send channel in Go (e.g. `chan<-`). -newtype SendChannel a = SendChannel { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 SendChannel where liftEq = genericLiftEq -instance Ord1 SendChannel where liftCompare = genericLiftCompare -instance Show1 SendChannel where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for SendChannel -instance Evaluatable SendChannel diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs deleted file mode 100644 index d68ece97fa..0000000000 --- a/src/Language/PHP/Assignment.hs +++ /dev/null @@ -1,693 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Language.PHP.Assignment -( assignment -, PHP.Syntax -, Grammar -, PHP.Term(..) -) where - -import qualified Analysis.Name as Name -import Assigning.Assignment hiding (Assignment, Error) -import qualified Assigning.Assignment as Assignment -import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..)) -import Data.Foldable -import Data.List.NonEmpty (NonEmpty (..), some1) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Sum -import Data.Syntax - ( contextualize - , emptyTerm - , handleError - , infixContext - , makeTerm - , makeTerm' - , makeTerm1 - , parseError - , postContextualize - ) -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import qualified Language.PHP.Syntax as Syntax -import Language.PHP.Term as PHP -import Language.PHP.Grammar as Grammar - -type Assignment = Assignment.Assignment Grammar - --- | Assignment from AST in PHP's grammar onto a program in PHP's syntax. -assignment :: Assignment (Term Loc) -assignment = handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> (bookend <$> (text <|> emptyTerm) <*> manyTerm statement <*> (text <|> emptyTerm))) <|> parseError - -text :: Assignment (Term Loc) -text = makeTerm <$> symbol Text <*> (Syntax.Text <$> source) - -textInterpolation :: Assignment (Term Loc) -textInterpolation = makeTerm <$> symbol TextInterpolation <*> (Syntax.Text <$> source) - -statement :: Assignment (Term Loc) -statement = handleError everything - where - everything = choice [ - compoundStatement - , namedLabelStatement - , expressionStatement - , selectionStatement - , iterationStatement - , jumpStatement - , tryStatement - , declareStatement - , echoStatement - , unsetStatement - , constDeclaration - , functionDefinition - , classDeclaration - , interfaceDeclaration - , traitDeclaration - , namespaceDefinition - , namespaceUseDeclaration - , globalDeclaration - , functionStaticDeclaration - ] - -expression :: Assignment (Term Loc) -expression = choice [ - assignmentExpression, - augmentedAssignmentExpression, - conditionalExpression, - yieldExpression, - includeExpression, - includeOnceExpression, - requireExpression, - requireOnceExpression, - binaryExpression, - unaryExpression - ] - -unaryExpression :: Assignment (Term Loc) -unaryExpression = choice [ - cloneExpression, - exponentiationExpression, - unaryOpExpression, - castExpression, - primaryExpression - ] - -assignmentExpression :: Assignment (Term Loc) -assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (variable <|> list <|> arrayCreationExpression) <*> term (expression <|> variable)) - -augmentedAssignmentExpression :: Assignment (Term Loc) -augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm variable (term expression) [ - assign Expression.Power <$ symbol AnonStarStarEqual - , assign Expression.Times <$ symbol AnonStarEqual - , assign Expression.Modulo <$ symbol AnonPercentEqual - , assign Expression.DividedBy <$ symbol AnonSlashEqual - , assign Expression.Plus <$ symbol AnonPlusEqual - , assign Expression.Minus <$ symbol AnonMinusEqual - , assign Syntax.Concat <$ symbol AnonDotEqual - , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual - , assign Expression.RShift <$ symbol AnonRAngleRAngleEqual - , assign Expression.BAnd <$ symbol AnonAmpersandEqual - , assign Expression.BXOr <$ symbol AnonCaretEqual - , assign Expression.BOr <$ symbol AnonPipeEqual ]) - where - assign c l r = inject (Statement.Assignment [] l (makeTerm1 (c l r))) - -binaryExpression :: Assignment (Term Loc) -binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term (expression <|> classTypeDesignator)) - [ (inject .) . Expression.And <$ symbol AnonAnd - , (inject .) . Expression.Or <$ symbol AnonOr - , (inject .) . Expression.XOr <$ symbol AnonXor - , (inject .) . Expression.Or <$ symbol AnonPipePipe - , (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand - , (inject .) . Expression.BOr <$ symbol AnonPipe - , (inject .) . Expression.BXOr <$ symbol AnonCaret - , (inject .) . Expression.BAnd <$ symbol AnonAmpersand - , (inject .) . Expression.Or <$ symbol AnonQuestionQuestion -- Not sure if this is right. - , (inject .) . Expression.Equal <$ symbol AnonEqualEqual - , (inject .) . Expression.StrictEqual <$ symbol AnonEqualEqualEqual - , (inject .) . invert Expression.Equal <$ (symbol AnonBangEqual <|> symbol AnonLAngleRAngle) - , (inject .) . invert Expression.StrictEqual <$ symbol AnonBangEqualEqual - , (inject .) . Expression.LessThan <$ symbol AnonLAngle - , (inject .) . Expression.GreaterThan <$ symbol AnonRAngle - , (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual - , (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual - , (inject .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle - , (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle - , (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle - , (inject .) . Expression.Plus <$ symbol AnonPlus - , (inject .) . Expression.Minus <$ symbol AnonMinus - , (inject .) . Expression.Times <$ symbol AnonStar - , (inject .) . Syntax.Concat <$ symbol AnonDot - , (inject .) . Expression.DividedBy <$ symbol AnonSlash - , (inject .) . Expression.Modulo <$ symbol AnonPercent - , (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof - ]) where invert cons a b = Expression.Not (makeTerm1 (cons a b)) - -conditionalExpression :: Assignment (Term Loc) -conditionalExpression = makeTerm <$> symbol ConditionalExpression <*> children (Statement.If <$> term (binaryExpression <|> unaryExpression) <*> (term expression <|> emptyTerm) <*> term expression) - -list :: Assignment (Term Loc) -list = makeTerm <$> symbol ListLiteral <*> children (Literal.Array <$> manyTerm (list <|> variable)) - -exponentiationExpression :: Assignment (Term Loc) -exponentiationExpression = makeTerm <$> symbol ExponentiationExpression <*> children (Expression.Power <$> term (cloneExpression <|> primaryExpression) <*> term (primaryExpression <|> cloneExpression <|> exponentiationExpression)) - -cloneExpression :: Assignment (Term Loc) -cloneExpression = makeTerm <$> symbol CloneExpression <*> children (Syntax.Clone <$> term primaryExpression) - -primaryExpression :: Assignment (Term Loc) -primaryExpression = choice [ - variable, - classConstantAccessExpression, - qualifiedName, - literal, - arrayCreationExpression, - intrinsic, - anonymousFunctionCreationExpression, - objectCreationExpression, - updateExpression, - shellCommandExpression, - parenthesizedExpression - ] - -parenthesizedExpression :: Assignment (Term Loc) -parenthesizedExpression = symbol ParenthesizedExpression *> children (term expression) - -classConstantAccessExpression :: Assignment (Term Loc) -classConstantAccessExpression = makeTerm <$> symbol ClassConstantAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> name) - -variable :: Assignment (Term Loc) -variable = callableVariable <|> scopedPropertyAccessExpression <|> memberAccessExpression <|> castExpression - -callableVariable :: Assignment (Term Loc) -callableVariable = choice [ - simpleVariable', - subscriptExpression, - memberCallExpression, - scopedCallExpression, - functionCallExpression - ] - -memberCallExpression :: Assignment (Term Loc) -memberCallExpression = makeTerm <$> symbol MemberCallExpression <*> children (Expression.Call [] <$> (makeMemberAccess <$> location <*> term dereferencableExpression <*> memberName) <*> arguments <*> emptyTerm) - where makeMemberAccess loc expr memberName = makeTerm loc (Expression.MemberAccess expr memberName) - -scopedCallExpression :: Assignment (Term Loc) -scopedCallExpression = makeTerm <$> symbol ScopedCallExpression <*> children (Expression.Call [] <$> (makeMemberAccess <$> location <*> term scopeResolutionQualifier <*> memberName) <*> arguments <*> emptyTerm) - where makeMemberAccess loc expr memberName = makeTerm loc (Expression.MemberAccess expr memberName) - -functionCallExpression :: Assignment (Term Loc) -functionCallExpression = makeTerm <$> symbol FunctionCallExpression <*> children (Expression.Call [] <$> term (qualifiedName <|> callableExpression) <*> arguments <*> emptyTerm) - -callableExpression :: Assignment (Term Loc) -callableExpression = choice [ - callableVariable, - expression, - arrayCreationExpression, - string - ] - -subscriptExpression :: Assignment (Term Loc) -subscriptExpression = makeTerm <$> symbol SubscriptExpression <*> children (Expression.Subscript <$> term dereferencableExpression <*> (pure <$> (term expression <|> emptyTerm))) - -memberAccessExpression :: Assignment (Term Loc) -memberAccessExpression = makeTerm <$> symbol MemberAccessExpression <*> children (Expression.MemberAccess <$> term dereferencableExpression <*> memberName) - -dereferencableExpression :: Assignment (Term Loc) -dereferencableExpression = symbol DereferencableExpression *> children (term (variable <|> expression <|> arrayCreationExpression <|> string)) - -scopedPropertyAccessExpression :: Assignment (Term Loc) -scopedPropertyAccessExpression = makeTerm <$> symbol ScopedPropertyAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> simpleVariable') - -scopeResolutionQualifier :: Assignment (Term Loc) -scopeResolutionQualifier = choice [ - relativeScope, - qualifiedName, - dereferencableExpression - ] - -arrayCreationExpression :: Assignment (Term Loc) -arrayCreationExpression = makeTerm <$> symbol ArrayCreationExpression <*> children (Literal.Array <$> manyTerm arrayElementInitializer) - -intrinsic :: Assignment (Term Loc) -intrinsic = choice [ - emptyIntrinsic, - evalIntrinsic, - exitIntrinsic, - issetIntrinsic, - printIntrinsic - ] - -emptyIntrinsic :: Assignment (Term Loc) -emptyIntrinsic = makeTerm <$> symbol EmptyIntrinsic <*> children (Syntax.EmptyIntrinsic <$> term expression) - -evalIntrinsic :: Assignment (Term Loc) -evalIntrinsic = makeTerm <$> symbol EvalIntrinsic <*> children (Syntax.EvalIntrinsic <$> term expression) - -exitIntrinsic :: Assignment (Term Loc) -exitIntrinsic = makeTerm <$> symbol ExitIntrinsic <*> children (Syntax.ExitIntrinsic <$> (term expression <|> emptyTerm)) - -issetIntrinsic :: Assignment (Term Loc) -issetIntrinsic = makeTerm <$> symbol IssetIntrinsic <*> children (Syntax.IssetIntrinsic <$> (makeTerm <$> location <*> someTerm variable)) - -printIntrinsic :: Assignment (Term Loc) -printIntrinsic = makeTerm <$> symbol PrintIntrinsic <*> children (Syntax.PrintIntrinsic <$> term expression) - -anonymousFunctionCreationExpression :: Assignment (Term Loc) -anonymousFunctionCreationExpression = makeTerm <$> symbol AnonymousFunctionCreationExpression <*> children (makeFunction <$> emptyTerm <*> parameters <*> (term functionUseClause <|> emptyTerm) <*> (term returnType <|> emptyTerm) <*> term compoundStatement) - where - makeFunction identifier parameters functionUseClause returnType statement = Declaration.Function [functionUseClause, returnType] identifier parameters statement - -parameters :: Assignment [Term Loc] -parameters = symbol FormalParameters *> children (manyTerm (simpleParameter <|> variadicParameter)) - -simpleParameter :: Assignment (Term Loc) -simpleParameter = makeTerm <$> symbol SimpleParameter <*> children (makeAnnotation <$> (term typeDeclaration <|> emptyTerm) <*> (makeAssignment <$> location <*> term variableName <*> (term defaultArgumentSpecifier <|> emptyTerm))) - where - makeAnnotation typeDecl assignment = Type.Annotation assignment typeDecl - makeAssignment loc name argument = makeTerm loc (Statement.Assignment [] name argument) - -defaultArgumentSpecifier :: Assignment (Term Loc) -defaultArgumentSpecifier = symbol DefaultArgumentSpecifier *> children (term expression) - - -variadicParameter :: Assignment (Term Loc) -variadicParameter = makeTerm <$> symbol VariadicParameter <*> children (makeTypeAnnotation <$> (term typeDeclaration <|> emptyTerm) <*> term variableName) - where makeTypeAnnotation ty variableName = Type.Annotation variableName ty - -functionUseClause :: Assignment (Term Loc) -functionUseClause = makeTerm <$> symbol AnonymousFunctionUseClause <*> children (Syntax.UseClause <$> someTerm variableName) - -returnType :: Assignment (Term Loc) -returnType = makeTerm <$> symbol ReturnType <*> children (Syntax.ReturnType <$> (term typeDeclaration <|> emptyTerm)) - -typeDeclaration :: Assignment (Term Loc) -typeDeclaration = makeTerm <$> symbol TypeDeclaration <*> children (Syntax.TypeDeclaration <$> term baseTypeDeclaration) - -baseTypeDeclaration :: Assignment (Term Loc) -baseTypeDeclaration = makeTerm <$> symbol BaseTypeDeclaration <*> children (Syntax.BaseTypeDeclaration <$> term (scalarType <|> qualifiedName <|> emptyTerm)) - -scalarType :: Assignment (Term Loc) -scalarType = makeTerm <$> symbol ScalarType <*> (Syntax.ScalarType <$> source) - -compoundStatement :: Assignment (Term Loc) -compoundStatement = makeTerm <$> symbol CompoundStatement <*> children (manyTerm statement) - -objectCreationExpression :: Assignment (Term Loc) -objectCreationExpression = makeTerm <$> symbol ObjectCreationExpression <*> children (Expression.New <$> term classTypeDesignator <*> emptyTerm <*> (arguments <|> pure [])) - - <|> (makeTerm <$> symbol ObjectCreationExpression <*> children (makeAnonClass <$ token AnonNew <* token AnonClass <*> emptyTerm <*> (arguments <|> pure []) <*> (term classBaseClause <|> emptyTerm) <*> (term classInterfaceClause <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm classMemberDeclaration))) - where makeAnonClass identifier args baseClause interfaceClause declarations = Declaration.Class [] identifier (args <> [baseClause, interfaceClause]) declarations - -classMemberDeclaration :: Assignment (Term Loc) -classMemberDeclaration = choice [ - classConstDeclaration, - propertyDeclaration, - methodDeclaration, - constructorDeclaration, - destructorDeclaration, - traitUseClause - ] - -publicAccessControl :: ScopeGraph.AccessControl -publicAccessControl = ScopeGraph.Public - --- TODO: Update to check for AccessControl. -methodDeclaration :: Assignment (Term Loc) -methodDeclaration = (makeTerm <$> symbol MethodDeclaration <*> children (makeMethod1 publicAccessControl <$> manyTerm methodModifier <*> emptyTerm <*> functionDefinitionParts)) - <|> makeTerm <$> symbol MethodDeclaration <*> children (makeMethod2 publicAccessControl <$> someTerm methodModifier <*> emptyTerm <*> term name <*> parameters <*> term (returnType <|> emptyTerm) <*> emptyTerm) - where - functionDefinitionParts = symbol FunctionDefinition *> children ((,,,) <$> term name <*> parameters <*> term (returnType <|> emptyTerm) <*> (term compoundStatement <|> emptyTerm)) - makeMethod1 accessControl modifiers receiver (name, params, returnType, compoundStatement) = Declaration.Method (modifiers <> [returnType]) receiver name params compoundStatement accessControl - makeMethod2 accessControl modifiers receiver name params returnType compoundStatement = Declaration.Method (modifiers <> [returnType]) receiver name params compoundStatement accessControl - -classBaseClause :: Assignment (Term Loc) -classBaseClause = makeTerm <$> symbol ClassBaseClause <*> children (Syntax.ClassBaseClause <$> term qualifiedName) - -classInterfaceClause :: Assignment (Term Loc) -classInterfaceClause = makeTerm <$> symbol ClassInterfaceClause <*> children (Syntax.ClassInterfaceClause <$> someTerm qualifiedName) - -classConstDeclaration :: Assignment (Term Loc) -classConstDeclaration = makeTerm <$> symbol ClassConstDeclaration <*> children (Syntax.ClassConstDeclaration <$> (term accessControlModifier <|> emptyTerm) <*> manyTerm constElement) - --- TODO: Update to ScopeGraph.AccessControl -accessControlModifier :: Assignment (Term Loc) -accessControlModifier = makeTerm <$> symbol VisibilityModifier <*> (Syntax.Identifier . Name.name <$> source) - -constElement :: Assignment (Term Loc) -constElement = makeTerm <$> symbol ConstElement <*> children (Statement.Assignment [] <$> term name <*> term expression) - -arguments :: Assignment [Term Loc] -arguments = symbol Arguments *> children (manyTerm (variadicUnpacking <|> expression)) - -variadicUnpacking :: Assignment (Term Loc) -variadicUnpacking = symbol VariadicUnpacking *> children (term expression) - -classTypeDesignator :: Assignment (Term Loc) -classTypeDesignator = qualifiedName <|> newVariable - -newVariable :: Assignment (Term Loc) -newVariable = makeTerm <$> symbol NewVariable <*> children (Syntax.NewVariable <$> ((pure <$> term simpleVariable') <|> ((\a b -> [a, b]) <$> term (newVariable <|> qualifiedName <|> relativeScope) <*> term (expression <|> memberName <|> emptyTerm)))) - -memberName :: Assignment (Term Loc) -memberName = name <|> simpleVariable' <|> expression - -relativeScope :: Assignment (Term Loc) -relativeScope = makeTerm <$> symbol RelativeScope <*> (Syntax.RelativeScope <$> source) - -qualifiedName :: Assignment (Term Loc) -qualifiedName = makeTerm <$> symbol QualifiedName <*> children (Syntax.QualifiedName <$> (term namespaceNameAsPrefix <|> emptyTerm) <*> term name) - -namespaceNameAsPrefix :: Assignment (Term Loc) -namespaceNameAsPrefix = symbol NamespaceNameAsPrefix *> children (term namespaceName <|> emptyTerm) - -namespaceName :: Assignment (Term Loc) -namespaceName = makeTerm <$> symbol NamespaceName <*> children (Syntax.NamespaceName <$> someTerm' name) - -namespaceName' :: Assignment (NonEmpty (Term Loc)) -namespaceName' = symbol NamespaceName *> children (someTerm' name) - -updateExpression :: Assignment (Term Loc) -updateExpression = makeTerm <$> symbol UpdateExpression <*> children (Syntax.Update <$> term expression) - -shellCommandExpression :: Assignment (Term Loc) -shellCommandExpression = makeTerm <$> symbol ShellCommandExpression <*> (Syntax.ShellCommand <$> source) - -literal :: Assignment (Term Loc) -literal = integer <|> float <|> string - -float :: Assignment (Term Loc) -float = makeTerm <$> symbol Float <*> (Literal.Float <$> source) - -integer :: Assignment (Term Loc) -integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) - -unaryOpExpression :: Assignment (Term Loc) -unaryOpExpression = symbol UnaryOpExpression >>= \ loc -> - makeTerm loc . Expression.Not <$> children ((symbol AnonTilde <|> symbol AnonBang) *> term expression) - <|> makeTerm loc . Expression.Negate <$> children ((symbol AnonMinus <|> symbol AnonPlus) *> term expression) - <|> makeTerm loc . Syntax.ErrorControl <$> children (symbol AnonAt *> term expression) - -castExpression :: Assignment (Term Loc) -castExpression = makeTerm <$> (symbol CastExpression <|> symbol CastExpression') <*> children (flip Expression.Cast <$> term castType <*> term unaryExpression) - -castType :: Assignment (Term Loc) -castType = makeTerm <$> symbol CastType <*> (Syntax.CastType <$> source) - -expressionStatement :: Assignment (Term Loc) -expressionStatement = symbol ExpressionStatement *> children (term expression) - -namedLabelStatement :: Assignment (Term Loc) -namedLabelStatement = makeTerm <$> symbol NamedLabelStatement <*> children (Syntax.LabeledStatement <$> term name) - -selectionStatement :: Assignment (Term Loc) -selectionStatement = ifStatement <|> switchStatement - -ifStatement :: Assignment (Term Loc) -ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term expression <*> (makeTerm <$> location <*> manyTerm statement) <*> (makeTerm <$> location <*> ((\as b -> as <> [b]) <$> manyTerm elseIfClause <*> (term elseClause <|> emptyTerm)))) - -switchStatement :: Assignment (Term Loc) -switchStatement = makeTerm <$> symbol SwitchStatement <*> children (Statement.Match <$> term expression <*> (makeTerm <$> location <*> manyTerm (caseStatement <|> defaultStatement))) - -caseStatement :: Assignment (Term Loc) -caseStatement = makeTerm <$> symbol CaseStatement <*> children (Statement.Pattern <$> term expression <*> (makeTerm <$> location <*> manyTerm statement)) - -defaultStatement :: Assignment (Term Loc) -defaultStatement = makeTerm <$> symbol DefaultStatement <*> children (Statement.Pattern <$> emptyTerm <*> (makeTerm <$> location <*> manyTerm statement)) - -elseIfClause :: Assignment (Term Loc) -elseIfClause = makeTerm <$> symbol ElseIfClause <*> children (Statement.Else <$> term expression <*> (makeTerm <$> location <*> manyTerm statement)) - -elseClause :: Assignment (Term Loc) -elseClause = makeTerm <$> symbol ElseClause <*> children (Statement.Else <$> emptyTerm <*> (makeTerm <$> location <*> manyTerm statement)) - -iterationStatement :: Assignment (Term Loc) -iterationStatement = choice [ - whileStatement, - doStatement, - forStatement, - foreachStatement - ] - -whileStatement :: Assignment (Term Loc) -whileStatement = makeTerm <$> symbol WhileStatement <*> children (Statement.While <$> expression <*> (term (statement <|> (makeTerm <$> location <*> manyTerm statement)) <|> emptyTerm)) - -doStatement :: Assignment (Term Loc) -doStatement = makeTerm <$> symbol DoStatement <*> children (Statement.DoWhile <$> term statement <*> term expression) - -forStatement :: Assignment (Term Loc) -forStatement = makeTerm <$> symbol ForStatement <*> children (Statement.For <$> (term expressions <|> emptyTerm) <*> (term expressions <|> emptyTerm) <*> (term expressions <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm statement)) - -foreachStatement :: Assignment (Term Loc) -foreachStatement = makeTerm <$> symbol ForeachStatement <*> children (forEachStatement' <$> term expression <*> term (pair <|> expression <|> list) <*> (makeTerm <$> location <*> manyTerm statement)) - where forEachStatement' array value body = Statement.ForEach value array body - -pair :: Assignment (Term Loc) -pair = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> term expression <*> term (expression <|> list)) - -jumpStatement :: Assignment (Term Loc) -jumpStatement = choice [ - gotoStatement, - continueStatement, - breakStatement, - returnStatement, - throwStatement - ] - -gotoStatement :: Assignment (Term Loc) -gotoStatement = makeTerm <$> symbol GotoStatement <*> children (Statement.Goto <$> term name) - -continueStatement :: Assignment (Term Loc) -continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (term breakoutLevel <|> emptyTerm)) - -breakoutLevel :: Assignment (Term Loc) -breakoutLevel = integer - -breakStatement :: Assignment (Term Loc) -breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (term breakoutLevel <|> emptyTerm)) - -returnStatement :: Assignment (Term Loc) -returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expression <|> emptyTerm)) - -throwStatement :: Assignment (Term Loc) -throwStatement = makeTerm <$> symbol ThrowStatement <*> children (Statement.Throw <$> term expression) - - -tryStatement :: Assignment (Term Loc) -tryStatement = makeTerm <$> symbol TryStatement <*> children (Statement.Try <$> term compoundStatement <*> (((\as b -> as <> [b]) <$> someTerm catchClause <*> term finallyClause) <|> someTerm catchClause <|> someTerm finallyClause)) - -catchClause :: Assignment (Term Loc) -catchClause = makeTerm <$> symbol CatchClause <*> children (Statement.Catch <$> (makeTerm <$> location <*> ((\a b -> [a, b]) <$> term qualifiedName <*> term variableName)) <*> term compoundStatement) - -finallyClause :: Assignment (Term Loc) -finallyClause = makeTerm <$> symbol FinallyClause <*> children (Statement.Finally <$> term compoundStatement) - -declareStatement :: Assignment (Term Loc) -declareStatement = makeTerm <$> symbol DeclareStatement <*> children (Syntax.Declare <$> term declareDirective <*> (makeTerm <$> location <*> manyTerm statement)) - - --- | TODO: Figure out how to parse assignment token -declareDirective :: Assignment (Term Loc) -declareDirective = makeTerm <$> symbol DeclareDirective <*> children (Syntax.DeclareDirective <$> literal) - - -echoStatement :: Assignment (Term Loc) -echoStatement = makeTerm <$> symbol EchoStatement <*> children (Syntax.Echo <$> term expressions) - -unsetStatement :: Assignment (Term Loc) -unsetStatement = makeTerm <$> symbol UnsetStatement <*> children (Syntax.Unset <$> (makeTerm <$> location <*> someTerm variable)) - -expressions :: Assignment (Term Loc) -expressions = expression <|> sequenceExpression - -sequenceExpression :: Assignment (Term Loc) -sequenceExpression = makeTerm <$> symbol SequenceExpression <*> children (Expression.SequenceExpression <$> term expression <*> term expressions) - -constDeclaration :: Assignment (Term Loc) -constDeclaration = makeTerm <$> symbol ConstDeclaration <*> children (Syntax.ConstDeclaration <$> someTerm constElement) - -functionDefinition :: Assignment (Term Loc) -functionDefinition = makeTerm <$> symbol FunctionDefinition <*> children (makeFunction <$> term name <*> parameters <*> (term returnType <|> emptyTerm) <*> term compoundStatement) - where - makeFunction identifier parameters returnType statement = Declaration.Function [returnType] identifier parameters statement - -classDeclaration :: Assignment (Term Loc) -classDeclaration = makeTerm <$> symbol ClassDeclaration <*> children (makeClass <$> (term classModifier <|> emptyTerm) <*> term name <*> (term classBaseClause <|> emptyTerm) <*> (term classInterfaceClause <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm classMemberDeclaration)) - where - makeClass modifier name baseClause interfaceClause declarations = Declaration.Class [modifier] name [baseClause, interfaceClause] declarations - -interfaceDeclaration :: Assignment (Term Loc) -interfaceDeclaration = makeTerm <$> symbol InterfaceDeclaration <*> children (Syntax.InterfaceDeclaration <$> term name <*> (term interfaceBaseClause <|> emptyTerm) <*> manyTerm interfaceMemberDeclaration) - -interfaceBaseClause :: Assignment (Term Loc) -interfaceBaseClause = makeTerm <$> symbol InterfaceBaseClause <*> children (Syntax.InterfaceBaseClause <$> someTerm qualifiedName) - -interfaceMemberDeclaration :: Assignment (Term Loc) -interfaceMemberDeclaration = methodDeclaration <|> classConstDeclaration - -traitDeclaration :: Assignment (Term Loc) -traitDeclaration = makeTerm <$> symbol TraitDeclaration <*> children (Syntax.TraitDeclaration <$> term name <*> manyTerm traitMemberDeclaration) - -traitMemberDeclaration :: Assignment (Term Loc) -traitMemberDeclaration = choice [ - propertyDeclaration, - methodDeclaration, - constructorDeclaration, - destructorDeclaration, - traitUseClause - ] - -propertyDeclaration :: Assignment (Term Loc) -propertyDeclaration = makeTerm <$> symbol PropertyDeclaration <*> children (Syntax.PropertyDeclaration <$> term propertyModifier <*> someTerm propertyElement) - -propertyModifier :: Assignment (Term Loc) -propertyModifier = (makeTerm <$> symbol PropertyModifier <*> children (Syntax.PropertyModifier <$> (term accessControlModifier <|> emptyTerm) <*> (term staticModifier <|> emptyTerm))) <|> term (makeTerm <$> symbol PropertyModifier <*> (Syntax.Identifier . Name.name <$> source)) - -propertyElement :: Assignment (Term Loc) -propertyElement = makeTerm <$> symbol PropertyElement <*> children (Statement.Assignment [] <$> term variableName <*> term propertyInitializer) <|> (symbol PropertyElement *> children (term variableName)) - where propertyInitializer = symbol PropertyInitializer *> children (term expression) - -constructorDeclaration :: Assignment (Term Loc) -constructorDeclaration = makeTerm <$> symbol ConstructorDeclaration <*> children (Syntax.ConstructorDeclaration <$> someTerm methodModifier <*> parameters <*> term compoundStatement) - -destructorDeclaration :: Assignment (Term Loc) -destructorDeclaration = makeTerm <$> symbol DestructorDeclaration <*> children (Syntax.DestructorDeclaration <$> someTerm methodModifier <*> term compoundStatement) - -methodModifier :: Assignment (Term Loc) -methodModifier = choice [ - accessControlModifier, - classModifier, - staticModifier - ] - -staticModifier :: Assignment (Term Loc) -staticModifier = makeTerm <$> symbol StaticModifier <*> (Syntax.Static <$> source) - -classModifier :: Assignment (Term Loc) -classModifier = makeTerm <$> symbol ClassModifier <*> (Syntax.ClassModifier <$> source) - -traitUseClause :: Assignment (Term Loc) -traitUseClause = makeTerm <$> symbol TraitUseClause <*> children (Syntax.TraitUseClause <$> someTerm qualifiedName <*> (term traitUseSpecification <|> emptyTerm)) - -traitUseSpecification :: Assignment (Term Loc) -traitUseSpecification = makeTerm <$> symbol TraitUseSpecification <*> children (Syntax.TraitUseSpecification <$> manyTerm traitSelectAndAliasClause) - -traitSelectAndAliasClause :: Assignment (Term Loc) -traitSelectAndAliasClause = traitSelectInsteadOfClause <|> traitAliasAsClause - -traitSelectInsteadOfClause :: Assignment (Term Loc) -traitSelectInsteadOfClause = makeTerm <$> symbol TraitSelectInsteadOfClause <*> children (Syntax.InsteadOf <$> term (classConstantAccessExpression <|> name) <*> term name) - -traitAliasAsClause :: Assignment (Term Loc) -traitAliasAsClause = makeTerm <$> symbol TraitAliasAsClause <*> children (Syntax.AliasAs <$> term (classConstantAccessExpression <|> name) <*> (term accessControlModifier <|> emptyTerm) <*> (term name <|> emptyTerm)) - -namespaceDefinition :: Assignment (Term Loc) -namespaceDefinition = makeTerm <$> symbol NamespaceDefinition <*> children (Syntax.Namespace <$> (toList <$> namespaceName' <|> pure []) <*> (term compoundStatement <|> emptyTerm)) - -namespaceUseDeclaration :: Assignment (Term Loc) -namespaceUseDeclaration = makeTerm <$> symbol NamespaceUseDeclaration <*> children (Syntax.NamespaceUseDeclaration <$> - ((mappend <$> (pure <$> (term namespaceFunctionOrConst <|> emptyTerm)) <*> someTerm namespaceUseClause) <|> ((\a b cs -> a : b : cs) <$> term namespaceFunctionOrConst <*> term namespaceName <*> someTerm namespaceUseGroupClause1) <|> ((:) <$> term namespaceName <*> someTerm namespaceUseGroupClause2))) - -namespaceUseClause :: Assignment (Term Loc) -namespaceUseClause = makeTerm <$> symbol NamespaceUseClause <*> children (fmap Syntax.NamespaceUseClause $ (\a b -> [a, b]) <$> term qualifiedName <*> (term namespaceAliasingClause <|> emptyTerm)) - -namespaceUseGroupClause1 :: Assignment (Term Loc) -namespaceUseGroupClause1 = makeTerm <$> symbol NamespaceUseGroupClause_1 <*> children (fmap Syntax.NamespaceUseGroupClause $ (\a b -> [a, b]) <$> term namespaceName <*> (term namespaceAliasingClause <|> emptyTerm)) - -namespaceUseGroupClause2 :: Assignment (Term Loc) -namespaceUseGroupClause2 = makeTerm <$> symbol NamespaceUseGroupClause_2 <*> children (fmap Syntax.NamespaceUseGroupClause $ (\a b c -> [a, b, c]) <$> (term namespaceFunctionOrConst <|> emptyTerm) <*> term namespaceName <*> (term namespaceAliasingClause <|> emptyTerm)) - -namespaceAliasingClause :: Assignment (Term Loc) -namespaceAliasingClause = makeTerm <$> symbol NamespaceAliasingClause <*> children (Syntax.NamespaceAliasingClause <$> term name) - --- | TODO Do something better than Identifier -namespaceFunctionOrConst :: Assignment (Term Loc) -namespaceFunctionOrConst = makeTerm <$> symbol NamespaceFunctionOrConst <*> (Syntax.Identifier . Name.name <$> source) - -globalDeclaration :: Assignment (Term Loc) -globalDeclaration = makeTerm <$> symbol GlobalDeclaration <*> children (Syntax.GlobalDeclaration <$> manyTerm simpleVariable') - -simpleVariable :: Assignment (Term Loc) -simpleVariable = makeTerm <$> symbol SimpleVariable <*> children (Syntax.SimpleVariable <$> term (simpleVariable' <|> expression)) - -simpleVariable' :: Assignment (Term Loc) -simpleVariable' = choice [simpleVariable, variableName] - - -yieldExpression :: Assignment (Term Loc) -yieldExpression = makeTerm <$> symbol YieldExpression <*> children (Statement.Yield <$> term (arrayElementInitializer <|> expression)) - -arrayElementInitializer :: Assignment (Term Loc) -arrayElementInitializer = makeTerm <$> symbol ArrayElementInitializer <*> children (Literal.KeyValue <$> term expression <*> term expression) <|> (symbol ArrayElementInitializer *> children (term expression)) - -includeExpression :: Assignment (Term Loc) -includeExpression = makeTerm <$> symbol IncludeExpression <*> children (Syntax.Include <$> term expression) - - -includeOnceExpression :: Assignment (Term Loc) -includeOnceExpression = makeTerm <$> symbol IncludeOnceExpression <*> children (Syntax.IncludeOnce <$> term expression) - -requireExpression :: Assignment (Term Loc) -requireExpression = makeTerm <$> symbol RequireExpression <*> children (Syntax.Require <$> term expression) - - -requireOnceExpression :: Assignment (Term Loc) -requireOnceExpression = makeTerm <$> symbol RequireOnceExpression <*> children (Syntax.RequireOnce <$> term expression) - -variableName :: Assignment (Term Loc) -variableName = makeTerm <$> symbol VariableName <*> children (Syntax.VariableName <$> term name) - -name :: Assignment (Term Loc) -name = makeTerm <$> (symbol Name <|> symbol Name') <*> (Syntax.Identifier . Name.name <$> source) - -functionStaticDeclaration :: Assignment (Term Loc) -functionStaticDeclaration = makeTerm <$> symbol FunctionStaticDeclaration <*> children (Declaration.VariableDeclaration <$> manyTerm staticVariableDeclaration) - -staticVariableDeclaration :: Assignment (Term Loc) -staticVariableDeclaration = makeTerm <$> symbol StaticVariableDeclaration <*> children (Statement.Assignment [] <$> term variableName <*> (term expression <|> emptyTerm)) - -comment :: Assignment (Term Loc) -comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) - -string :: Assignment (Term Loc) -string = makeTerm <$> (symbol Grammar.String <|> symbol Heredoc) <*> (Literal.TextElement <$> source) - - --- Helpers - -append :: a -> [a] -> [a] -append x xs = xs <> [x] - -bookend :: a -> [a] -> a -> [a] -bookend head_ list last_ = head_ : append last_ list - -term :: Assignment (Term Loc) -> Assignment (Term Loc) -term term = contextualize (comment <|> textInterpolation) (postContextualize (comment <|> textInterpolation) term) - -commentedTerm :: Assignment (Term Loc) -> Assignment (Term Loc) -commentedTerm term = contextualize (comment <|> textInterpolation) term <|> makeTerm1 <$> (Syntax.Context <$> some1 (comment <|> textInterpolation) <*> emptyTerm) - --- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] -manyTerm = many . commentedTerm - -someTerm :: Assignment (Term Loc) -> Assignment [Term Loc] -someTerm = fmap NonEmpty.toList . someTerm' - -someTerm' :: Assignment (Term Loc) -> Assignment (NonEmpty (Term Loc)) -someTerm' = NonEmpty.some1 . commentedTerm - --- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment (Term Loc) - -> Assignment (Term Loc) - -> [Assignment (Term Loc -> Term Loc -> Sum PHP.Syntax (Term Loc))] - -> Assignment (Sum PHP.Syntax (Term Loc)) -infixTerm = infixContext (comment <|> textInterpolation) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs deleted file mode 100644 index dd61975562..0000000000 --- a/src/Language/PHP/Syntax.hs +++ /dev/null @@ -1,601 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -module Language.PHP.Syntax (module Language.PHP.Syntax) where - -import Control.Lens.Getter -import Data.Functor.Classes -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map.Strict as Map -import Data.Maybe.Exts -import qualified Data.Text as T -import GHC.Generics (Generic1) - -import Control.Abstract as Abstract -import Data.Abstract.BaseError -import Data.Abstract.Evaluatable as Abstract -import Data.Abstract.Module -import Data.Abstract.Path -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import qualified Data.Language as Language -import Source.Span -import qualified System.Path as Path - -newtype Text a = Text { value :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Text where liftEq = genericLiftEq -instance Ord1 Text where liftCompare = genericLiftCompare -instance Show1 Text where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Text - -newtype VariableName a = VariableName { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 VariableName where liftEq = genericLiftEq -instance Ord1 VariableName where liftCompare = genericLiftCompare -instance Show1 VariableName where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable VariableName - --- TODO: Variables defined in an included file take on scope of the source line --- on which the inclusion occurs in the including file. However, functions and --- classes defined in the included file are always in global scope. - --- TODO: If inclusion occurs inside a function definition within the including --- file, the complete contents of the included file are treated as though it --- were defined inside that function. - -resolvePHPName :: ( Has (Modules address value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - ) - => T.Text - -> Evaluator term address value m ModulePath -resolvePHPName n = do - modulePath <- resolve [name] - maybeM (throwResolutionError $ NotFoundError (Path.toFileDir name) [name] Language.PHP) modulePath - where name = toName n - toName = Path.absRel . T.unpack . dropRelativePrefix . stripQuotes - -include :: ( Has (Modules address value) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (State (ScopeGraph address)) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - , Has (State (Heap address address value)) sig m - , Has (Abstract.String value) sig m - , Has Trace sig m - , Ord address - ) - => (term -> Evaluator term address value m value) - -> term - -> (ModulePath -> Evaluator term address value m (ModuleResult address value)) - -> Evaluator term address value m value -include eval pathTerm f = do - name <- eval pathTerm >>= asString - path <- resolvePHPName name - traceResolve name path - ((moduleScope, moduleFrame), v) <- f path - insertImportEdge moduleScope - insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - pure v - -newtype Require a = Require { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Require where liftEq = genericLiftEq -instance Ord1 Require where liftCompare = genericLiftCompare -instance Show1 Require where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Require where - eval eval _ (Require path) = include eval path load - - -newtype RequireOnce a = RequireOnce { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 RequireOnce where liftEq = genericLiftEq -instance Ord1 RequireOnce where liftCompare = genericLiftCompare -instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable RequireOnce where - eval eval _ (RequireOnce path) = include eval path require - -newtype Include a = Include { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Include where liftEq = genericLiftEq -instance Ord1 Include where liftCompare = genericLiftCompare -instance Show1 Include where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Include where - eval eval _ (Include path) = include eval path load - -newtype IncludeOnce a = IncludeOnce { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 IncludeOnce where liftEq = genericLiftEq -instance Ord1 IncludeOnce where liftCompare = genericLiftCompare -instance Show1 IncludeOnce where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable IncludeOnce where - eval eval _ (IncludeOnce path) = include eval path require - -newtype ArrayElement a = ArrayElement { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ArrayElement where liftEq = genericLiftEq -instance Ord1 ArrayElement where liftCompare = genericLiftCompare -instance Show1 ArrayElement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ArrayElement - -newtype GlobalDeclaration a = GlobalDeclaration { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 GlobalDeclaration where liftEq = genericLiftEq -instance Ord1 GlobalDeclaration where liftCompare = genericLiftCompare -instance Show1 GlobalDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable GlobalDeclaration - -newtype SimpleVariable a = SimpleVariable { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 SimpleVariable where liftEq = genericLiftEq -instance Ord1 SimpleVariable where liftCompare = genericLiftCompare -instance Show1 SimpleVariable where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable SimpleVariable - -data Concat a = Concat { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Concat where liftEq = genericLiftEq -instance Ord1 Concat where liftCompare = genericLiftCompare -instance Show1 Concat where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Concat - --- | TODO: Unify with TypeScript's PredefinedType -newtype CastType a = CastType { _castType :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 CastType where liftEq = genericLiftEq -instance Ord1 CastType where liftCompare = genericLiftCompare -instance Show1 CastType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable CastType - -newtype ErrorControl a = ErrorControl { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ErrorControl where liftEq = genericLiftEq -instance Ord1 ErrorControl where liftCompare = genericLiftCompare -instance Show1 ErrorControl where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ErrorControl - -newtype Clone a = Clone { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Clone where liftEq = genericLiftEq -instance Ord1 Clone where liftCompare = genericLiftCompare -instance Show1 Clone where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Clone - -newtype ShellCommand a = ShellCommand { value :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ShellCommand where liftEq = genericLiftEq -instance Ord1 ShellCommand where liftCompare = genericLiftCompare -instance Show1 ShellCommand where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ShellCommand - --- | TODO: Combine with TypeScript update expression. -newtype Update a = Update { _updateSubject :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Update where liftEq = genericLiftEq -instance Ord1 Update where liftCompare = genericLiftCompare -instance Show1 Update where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable Update - -newtype NewVariable a = NewVariable { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NewVariable where liftEq = genericLiftEq -instance Ord1 NewVariable where liftCompare = genericLiftCompare -instance Show1 NewVariable where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NewVariable - -newtype RelativeScope a = RelativeScope { value :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 RelativeScope where liftEq = genericLiftEq -instance Ord1 RelativeScope where liftCompare = genericLiftCompare -instance Show1 RelativeScope where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable RelativeScope - -data QualifiedName a = QualifiedName { name :: a, identifier :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 QualifiedName where liftEq = genericLiftEq -instance Ord1 QualifiedName where liftCompare = genericLiftCompare -instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QualifiedName where - eval _ _ (QualifiedName obj iden) = do - -- TODO: Consider gensym'ed names used for References. - name <- maybeM (throwNoNameError obj) (declaredName obj) - reference (Reference name) (obj^.span_) ScopeGraph.Identifier (Declaration name) - childScope <- associatedScope (Declaration name) - - propName <- maybeM (throwNoNameError iden) (declaredName iden) - case childScope of - Just childScope -> do - currentScopeAddress <- currentScope - currentFrameAddress <- currentFrame - frameAddress <- newFrame childScope (Map.singleton Lexical (Map.singleton currentScopeAddress currentFrameAddress)) - withScopeAndFrame frameAddress $ do - reference (Reference propName) (iden^.span_) ScopeGraph.Identifier (Declaration propName) - slot <- lookupSlot (Declaration propName) - deref slot - Nothing -> - -- TODO: Throw an ReferenceError because we can't find the associated child scope for `obj`. - unit - -newtype NamespaceName a = NamespaceName { names :: NonEmpty a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Traversable) - -instance Eq1 NamespaceName where liftEq = genericLiftEq -instance Ord1 NamespaceName where liftCompare = genericLiftCompare -instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec - -instance Hashable1 NamespaceName where liftHashWithSalt = foldl - -instance Evaluatable NamespaceName - -newtype ConstDeclaration a = ConstDeclaration { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ConstDeclaration where liftEq = genericLiftEq -instance Ord1 ConstDeclaration where liftCompare = genericLiftCompare -instance Show1 ConstDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ConstDeclaration - -data ClassConstDeclaration a = ClassConstDeclaration { visibility :: a, elements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ClassConstDeclaration where liftEq = genericLiftEq -instance Ord1 ClassConstDeclaration where liftCompare = genericLiftCompare -instance Show1 ClassConstDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ClassConstDeclaration - -newtype ClassInterfaceClause a = ClassInterfaceClause { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ClassInterfaceClause where liftEq = genericLiftEq -instance Ord1 ClassInterfaceClause where liftCompare = genericLiftCompare -instance Show1 ClassInterfaceClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ClassInterfaceClause - -newtype ClassBaseClause a = ClassBaseClause { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ClassBaseClause where liftEq = genericLiftEq -instance Ord1 ClassBaseClause where liftCompare = genericLiftCompare -instance Show1 ClassBaseClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ClassBaseClause - -newtype UseClause a = UseClause { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 UseClause where liftEq = genericLiftEq -instance Ord1 UseClause where liftCompare = genericLiftCompare -instance Show1 UseClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable UseClause - -newtype ReturnType a = ReturnType { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ReturnType where liftEq = genericLiftEq -instance Ord1 ReturnType where liftCompare = genericLiftCompare -instance Show1 ReturnType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ReturnType - -newtype TypeDeclaration a = TypeDeclaration { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeDeclaration where liftEq = genericLiftEq -instance Ord1 TypeDeclaration where liftCompare = genericLiftCompare -instance Show1 TypeDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeDeclaration - -newtype BaseTypeDeclaration a = BaseTypeDeclaration { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 BaseTypeDeclaration where liftEq = genericLiftEq -instance Ord1 BaseTypeDeclaration where liftCompare = genericLiftCompare -instance Show1 BaseTypeDeclaration where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable BaseTypeDeclaration - -newtype ScalarType a = ScalarType { value :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ScalarType where liftEq = genericLiftEq -instance Ord1 ScalarType where liftCompare = genericLiftCompare -instance Show1 ScalarType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ScalarType - -newtype EmptyIntrinsic a = EmptyIntrinsic { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 EmptyIntrinsic where liftEq = genericLiftEq -instance Ord1 EmptyIntrinsic where liftCompare = genericLiftCompare -instance Show1 EmptyIntrinsic where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable EmptyIntrinsic - -newtype ExitIntrinsic a = ExitIntrinsic { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ExitIntrinsic where liftEq = genericLiftEq -instance Ord1 ExitIntrinsic where liftCompare = genericLiftCompare -instance Show1 ExitIntrinsic where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ExitIntrinsic - -newtype IssetIntrinsic a = IssetIntrinsic { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 IssetIntrinsic where liftEq = genericLiftEq -instance Ord1 IssetIntrinsic where liftCompare = genericLiftCompare -instance Show1 IssetIntrinsic where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable IssetIntrinsic - -newtype EvalIntrinsic a = EvalIntrinsic { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 EvalIntrinsic where liftEq = genericLiftEq -instance Ord1 EvalIntrinsic where liftCompare = genericLiftCompare -instance Show1 EvalIntrinsic where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable EvalIntrinsic - -newtype PrintIntrinsic a = PrintIntrinsic { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 PrintIntrinsic where liftEq = genericLiftEq -instance Ord1 PrintIntrinsic where liftCompare = genericLiftCompare -instance Show1 PrintIntrinsic where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable PrintIntrinsic - -newtype NamespaceAliasingClause a = NamespaceAliasingClause { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NamespaceAliasingClause where liftEq = genericLiftEq -instance Ord1 NamespaceAliasingClause where liftCompare = genericLiftCompare -instance Show1 NamespaceAliasingClause where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable NamespaceAliasingClause - -newtype NamespaceUseDeclaration a = NamespaceUseDeclaration { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NamespaceUseDeclaration where liftEq = genericLiftEq -instance Ord1 NamespaceUseDeclaration where liftCompare = genericLiftCompare -instance Show1 NamespaceUseDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NamespaceUseDeclaration - -newtype NamespaceUseClause a = NamespaceUseClause { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NamespaceUseClause where liftEq = genericLiftEq -instance Ord1 NamespaceUseClause where liftCompare = genericLiftCompare -instance Show1 NamespaceUseClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NamespaceUseClause - -newtype NamespaceUseGroupClause a = NamespaceUseGroupClause { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NamespaceUseGroupClause where liftEq = genericLiftEq -instance Ord1 NamespaceUseGroupClause where liftCompare = genericLiftCompare -instance Show1 NamespaceUseGroupClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NamespaceUseGroupClause - -data Namespace a = Namespace { namespaceName :: [a], namespaceBody :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Namespace where liftEq = genericLiftEq -instance Ord1 Namespace where liftCompare = genericLiftCompare -instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Namespace - -data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TraitDeclaration where liftEq = genericLiftEq -instance Ord1 TraitDeclaration where liftCompare = genericLiftCompare -instance Show1 TraitDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TraitDeclaration - -data AliasAs a = AliasAs { aliasAsName :: a, aliasAsModifier :: a, aliasAsClause :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 AliasAs where liftEq = genericLiftEq -instance Ord1 AliasAs where liftCompare = genericLiftCompare -instance Show1 AliasAs where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable AliasAs - -data InsteadOf a = InsteadOf { left :: a, right :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 InsteadOf where liftEq = genericLiftEq -instance Ord1 InsteadOf where liftCompare = genericLiftCompare -instance Show1 InsteadOf where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable InsteadOf - -newtype TraitUseSpecification a = TraitUseSpecification { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TraitUseSpecification where liftEq = genericLiftEq -instance Ord1 TraitUseSpecification where liftCompare = genericLiftCompare -instance Show1 TraitUseSpecification where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TraitUseSpecification - -data TraitUseClause a = TraitUseClause { namespace :: [a], alias :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TraitUseClause where liftEq = genericLiftEq -instance Ord1 TraitUseClause where liftCompare = genericLiftCompare -instance Show1 TraitUseClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TraitUseClause - -data DestructorDeclaration a = DestructorDeclaration { body:: [a], name :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 DestructorDeclaration where liftEq = genericLiftEq -instance Ord1 DestructorDeclaration where liftCompare = genericLiftCompare -instance Show1 DestructorDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable DestructorDeclaration - -newtype Static a = Static { value :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Static where liftEq = genericLiftEq -instance Ord1 Static where liftCompare = genericLiftCompare -instance Show1 Static where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Static - -newtype ClassModifier a = ClassModifier { value :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ClassModifier where liftEq = genericLiftEq -instance Ord1 ClassModifier where liftCompare = genericLiftCompare -instance Show1 ClassModifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ClassModifier - -data ConstructorDeclaration a = ConstructorDeclaration { modifiers :: [a], parameters :: [a], body :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ConstructorDeclaration where liftEq = genericLiftEq -instance Ord1 ConstructorDeclaration where liftCompare = genericLiftCompare -instance Show1 ConstructorDeclaration where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable ConstructorDeclaration - -data PropertyDeclaration a = PropertyDeclaration { modifier :: a, elements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 PropertyDeclaration where liftEq = genericLiftEq -instance Ord1 PropertyDeclaration where liftCompare = genericLiftCompare -instance Show1 PropertyDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable PropertyDeclaration - -data PropertyModifier a = PropertyModifier { visibility :: a , static :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 PropertyModifier where liftEq = genericLiftEq -instance Ord1 PropertyModifier where liftCompare = genericLiftCompare -instance Show1 PropertyModifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable PropertyModifier - -data InterfaceDeclaration a = InterfaceDeclaration { name :: a, base :: a, declarations :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq -instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare -instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable InterfaceDeclaration - -newtype InterfaceBaseClause a = InterfaceBaseClause { values :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 InterfaceBaseClause where liftEq = genericLiftEq -instance Ord1 InterfaceBaseClause where liftCompare = genericLiftCompare -instance Show1 InterfaceBaseClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable InterfaceBaseClause - -newtype Echo a = Echo { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Echo where liftEq = genericLiftEq -instance Ord1 Echo where liftCompare = genericLiftCompare -instance Show1 Echo where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Echo - -newtype Unset a = Unset { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Unset where liftEq = genericLiftEq -instance Ord1 Unset where liftCompare = genericLiftCompare -instance Show1 Unset where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Unset - -data Declare a = Declare { left :: a, right :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Declare where liftEq = genericLiftEq -instance Ord1 Declare where liftCompare = genericLiftCompare -instance Show1 Declare where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Declare - -newtype DeclareDirective a = DeclareDirective { value :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 DeclareDirective where liftEq = genericLiftEq -instance Ord1 DeclareDirective where liftCompare = genericLiftCompare -instance Show1 DeclareDirective where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable DeclareDirective - -newtype LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 LabeledStatement where liftEq = genericLiftEq -instance Ord1 LabeledStatement where liftCompare = genericLiftCompare -instance Show1 LabeledStatement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LabeledStatement diff --git a/src/Language/PHP/Term.hs b/src/Language/PHP/Term.hs deleted file mode 100644 index e4a7e2f023..0000000000 --- a/src/Language/PHP/Term.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, RecordWildCards, TypeFamilies #-} -module Language.PHP.Term -( Syntax -, Term(..) -) where - -import Control.Lens.Lens -import Data.Abstract.Declarations -import Data.Abstract.FreeVariables -import Data.Bitraversable -import Data.Coerce -import Data.Foldable (fold) -import Data.Functor.Foldable (Base, Recursive(..)) -import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) -import qualified Data.Sum as Sum -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term -import Data.Traversable -import qualified Language.PHP.Syntax as Syntax -import Source.Loc -import Source.Span - -type Syntax = - [ Comment.Comment - , Declaration.Class - , Declaration.Function - , Declaration.Method - , Declaration.VariableDeclaration - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.Call - , Expression.Cast - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.InstanceOf - , Expression.MemberAccess - , Expression.New - , Expression.SequenceExpression - , Expression.Subscript - , Expression.Member - , Literal.Array - , Literal.Float - , Literal.Integer - , Literal.KeyValue - , Literal.TextElement - , Statement.Assignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.DoWhile - , Statement.Else - , Statement.Finally - , Statement.For - , Statement.ForEach - , Statement.Goto - , Statement.If - , Statement.Match - , Statement.Pattern - , Statement.Return - , Statement.Statements - , Statement.Throw - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.AliasAs - , Syntax.ArrayElement - , Syntax.BaseTypeDeclaration - , Syntax.CastType - , Syntax.ClassBaseClause - , Syntax.ClassConstDeclaration - , Syntax.ClassInterfaceClause - , Syntax.ClassModifier - , Syntax.Clone - , Syntax.ConstDeclaration - , Syntax.ConstructorDeclaration - , Syntax.Context - , Syntax.Declare - , Syntax.DeclareDirective - , Syntax.DestructorDeclaration - , Syntax.Echo - , Syntax.Empty - , Syntax.EmptyIntrinsic - , Syntax.Error - , Syntax.ErrorControl - , Syntax.EvalIntrinsic - , Syntax.ExitIntrinsic - , Syntax.GlobalDeclaration - , Syntax.Identifier - , Syntax.Include - , Syntax.IncludeOnce - , Syntax.InsteadOf - , Syntax.InterfaceBaseClause - , Syntax.InterfaceDeclaration - , Syntax.IssetIntrinsic - , Syntax.LabeledStatement - , Syntax.Namespace - , Syntax.NamespaceAliasingClause - , Syntax.NamespaceName - , Syntax.NamespaceUseClause - , Syntax.NamespaceUseDeclaration - , Syntax.NamespaceUseGroupClause - , Syntax.NewVariable - , Syntax.PrintIntrinsic - , Syntax.PropertyDeclaration - , Syntax.PropertyModifier - , Syntax.QualifiedName - , Syntax.RelativeScope - , Syntax.Require - , Syntax.RequireOnce - , Syntax.ReturnType - , Syntax.ScalarType - , Syntax.ShellCommand - , Syntax.Concat - , Syntax.SimpleVariable - , Syntax.Static - , Syntax.Text - , Syntax.TraitDeclaration - , Syntax.TraitUseClause - , Syntax.TraitUseSpecification - , Syntax.TypeDeclaration - , Syntax.Unset - , Syntax.Update - , Syntax.UseClause - , Syntax.VariableName - , Type.Annotation - , [] - ] - - -newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } - deriving (Eq, Declarations, FreeVariables, Ord, Show) - -instance Term.IsTerm Term where - type Syntax Term = Sum.Sum Syntax - toTermF = coerce - fromTermF = coerce - -instance Foldable Term where - foldMap = foldMapDefault - -instance Functor Term where - fmap = fmapDefault - -instance Traversable Term where - traverse f = go where go = fmap Term . bitraverse f go . getTerm - -instance VertexDeclaration Term where - toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax - -instance Syntax.HasErrors Term where - getErrors = cata $ \ (Term.In Loc{..} syntax) -> - maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) - - -type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann - -instance Recursive (Term ann) where - project = getTerm - -instance HasSpan ann => HasSpan (Term ann) where - span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) - {-# INLINE span_ #-} diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs deleted file mode 100644 index 835ae55829..0000000000 --- a/src/Language/Python/Assignment.hs +++ /dev/null @@ -1,482 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Language.Python.Assignment -( assignment -, Python.Syntax -, Grammar -, Python.Term(..) -) where - -import Analysis.Name (name) -import Assigning.Assignment hiding (Assignment, Error) -import qualified Assigning.Assignment as Assignment -import Control.Monad -import Data.Functor -import Data.List.NonEmpty (some1) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe -import Data.Sum -import Data.Syntax - ( contextualize - , emptyTerm - , handleError - , infixContext - , makeTerm - , makeTerm' - , makeTerm'' - , makeTerm1 - , parseError - , postContextualize - ) -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import Language.Python.Grammar as Grammar -import Language.Python.Syntax as Python.Syntax -import Language.Python.Term as Python - -type Assignment = Assignment.Assignment Grammar - --- | Assignment from AST in Python's grammar onto a program in Python's syntax. -assignment :: Assignment (Term Loc) -assignment = handleError $ makeTerm <$> symbol Module <*> children (Statement.Statements <$> manyTerm expression) <|> parseError - -expression :: Assignment (Term Loc) -expression = handleError (choice expressionChoices) - -expressionChoices :: [Assignment (Term Loc)] -expressionChoices = - -- Long-term, can we de/serialize assignments and avoid paying the cost of construction altogether? - [ argumentList - , assertStatement - , assignment' - , await - , binaryOperator - , block - , boolean - , booleanOperator - , breakStatement - , call - , classDefinition - , comparisonOperator - , comprehension - , concatenatedString - , conditionalExpression - , continueStatement - , decoratedDefinition - , deleteStatement - , dictionary - , dictionarySplat - , ellipsis - , exceptClause - , execStatement - , expressionList - , expressionStatement - , finallyClause - , float - , forInClause - , forStatement - , functionDefinition - , globalStatement - , identifier - , ifClause - , ifStatement - , import' - , integer - , keywordArgument - , list' - , listSplat - , memberAccess - , none - , nonlocalStatement - , notOperator - , pair - , parameter - , parenthesizedExpression - , parseError - , passStatement - , printStatement - , raiseStatement - , returnStatement - , set - , slice - , string - , subscript - , tryStatement - , tuple - , type' - , unaryOperator - , variables - , whileStatement - , withStatement - , yield - ] - -expressions :: Assignment (Term Loc) -expressions = makeTerm'' <$> location <*> manyTerm expression - -block :: Assignment (Term Loc) -block = symbol Block *> children (makeTerm'' <$> location <*> manyTerm expression) - -block' :: Assignment (Term Loc) -block' = symbol Block *> children (makeTerm <$> location <*> manyTerm expression) - -expressionStatement :: Assignment (Term Loc) -expressionStatement = makeTerm'' <$> symbol ExpressionStatement <*> children (someTerm expression) - -expressionList :: Assignment (Term Loc) -expressionList = makeTerm'' <$> symbol ExpressionList <*> children (someTerm expression) - -listSplat :: Assignment (Term Loc) -listSplat = makeTerm <$> symbol ListSplat <*> children (manyTerm expression) - -dictionarySplat :: Assignment (Term Loc) -dictionarySplat = makeTerm <$> symbol DictionarySplat <*> children (manyTerm expression) - -keywordArgument :: Assignment (Term Loc) -keywordArgument = makeTerm <$> symbol KeywordArgument <*> children (Statement.Assignment [] <$> term expression <*> term expression) - -parenthesizedExpression :: Assignment (Term Loc) -parenthesizedExpression = (symbol ParenthesizedExpression <|> symbol ParenthesizedExpression') *> children expressions - -parameter :: Assignment (Term Loc) -parameter = makeTerm <$> symbol DefaultParameter <*> children (Statement.Assignment [] <$> term expression <*> term expression) - <|> makeTerm <$> symbol TypedParameter <*> children (Type.Annotation <$> term expression <*> term type') - <|> makeAnnotation <$> symbol TypedDefaultParameter <*> children ((,,) <$> term expression <*> term expression <*> term expression) - where - makeAnnotation loc (identifier', type', value') = makeTerm loc (Type.Annotation (makeAssignment loc identifier' value') type') - makeAssignment loc identifier' value' = makeTerm loc (Statement.Assignment [] identifier' value') - -decoratedDefinition :: Assignment (Term Loc) -decoratedDefinition = symbol DecoratedDefinition *> children (term decorator) - where - decorator = makeTerm <$> symbol Decorator <*> (children (Declaration.Decorator <$> term expression <*> manyTerm expression) <*> term (decorator <|> functionDefinition <|> classDefinition)) - -argumentList :: Assignment (Term Loc) -argumentList = symbol ArgumentList *> children expressions - -withStatement :: Assignment (Term Loc) -withStatement = symbol WithStatement *> children (flip (foldr make) <$> some withItem <*> term block') - where - make (val, name) = makeTerm1 . Statement.Let name val - withItem = symbol WithItem *> children ((,) <$> term expression <*> term (expression <|> emptyTerm)) - -forStatement :: Assignment (Term Loc) -forStatement = symbol ForStatement >>= \ loc -> children (make loc <$> (symbol Variables *> children expressions) <*> term expressionList <*> term block' <*> optional (symbol ElseClause *> children expressions)) - where - make loc binding subject body forElseClause = case forElseClause of - Nothing -> makeTerm loc (Statement.ForEach binding subject body) - Just a -> makeTerm loc (Statement.Else (makeTerm loc $ Statement.ForEach binding subject body) a) - -whileStatement :: Assignment (Term Loc) -whileStatement = symbol WhileStatement >>= \ loc -> children (make loc <$> term expression <*> term block <*> optional (symbol ElseClause *> children expressions)) - where - make loc whileCondition whileBody whileElseClause = case whileElseClause of - Nothing -> makeTerm loc (Statement.While whileCondition whileBody) - Just a -> makeTerm loc (Statement.Else (makeTerm loc $ Statement.While whileCondition whileBody) a) - -tryStatement :: Assignment (Term Loc) -tryStatement = makeTerm <$> symbol TryStatement <*> children (Statement.Try <$> term block <*> manyTerm (expression <|> elseClause)) - where elseClause = makeTerm <$> symbol ElseClause <*> children (Statement.Else <$> emptyTerm <*> term block) - -exceptClause :: Assignment (Term Loc) -exceptClause = makeTerm <$> symbol ExceptClause <*> children - (Statement.Catch <$> term ((makeTerm <$> location <*> (uncurry (flip Statement.Let) <$> ((,) <$> term expression <* symbol AnonAs <*> term expression) <*> emptyTerm)) - <|> expressions) - <*> expressions) - -functionParam :: Assignment (Term Loc) -functionParam = (makeParameter <$> location <*> identifier) - <|> tuple - <|> parameter - <|> listSplat - <|> dictionarySplat - where makeParameter loc term = makeTerm loc (Declaration.RequiredParameter term) - -functionDefinition :: Assignment (Term Loc) -functionDefinition = - makeFunctionDeclaration <$> symbol FunctionDefinition <*> children ((,,,) <$> term expression <* symbol Parameters <*> children (manyTerm functionParam) <*> optional (symbol Type *> children (term expression)) <*> term block') - <|> makeFunctionDeclaration <$> (symbol Lambda' <|> symbol Lambda) <*> children ((,,,) <$ token AnonLambda <*> emptyTerm <*> (symbol LambdaParameters *> children (manyTerm expression) <|> pure []) <*> optional (symbol Type *> children (term expression)) <*> expressions') - where - expressions' = makeTerm <$> location <*> manyTerm expression - makeFunctionDeclaration loc (functionName', functionParameters, ty, functionBody) - = let fn = makeTerm loc (Declaration.Function [] functionName' functionParameters functionBody) - in maybe fn (makeTerm loc . Type.Annotation fn) ty - -classDefinition :: Assignment (Term Loc) -classDefinition = makeTerm <$> symbol ClassDefinition <*> children (Declaration.Class [] <$> term expression <*> argumentList <*> term block') - where - argumentList = symbol ArgumentList *> children (manyTerm expression) - <|> pure [] - -type' :: Assignment (Term Loc) -type' = symbol Type *> children (term expression) - -finallyClause :: Assignment (Term Loc) -finallyClause = makeTerm <$> symbol FinallyClause <*> children (Statement.Finally <$> expressions) - -ellipsis :: Assignment (Term Loc) -ellipsis = makeTerm <$> token Grammar.Ellipsis <*> pure Python.Syntax.Ellipsis - -comparisonOperator :: Assignment (Term Loc) -comparisonOperator = symbol ComparisonOperator *> children (expression `chainl1Term` choice - [ (makeTerm1 .) . Expression.LessThan <$ token AnonLAngle - , (makeTerm1 .) . Expression.LessThanEqual <$ token AnonLAngleEqual - , (makeTerm1 .) . Expression.GreaterThan <$ token AnonRAngle - , (makeTerm1 .) . Expression.GreaterThanEqual <$ token AnonRAngleEqual - , (makeTerm1 .) . Expression.Equal <$ token AnonEqualEqual - , (makeTerm1 .) . invert Expression.Equal <$ token AnonBangEqual - , (makeTerm1 .) . invert Expression.Equal <$ token AnonLAngleRAngle - , (makeTerm1 .) . invert Expression.Member <$ token AnonNot - , (makeTerm1 .) . Expression.Member <$ token AnonIn - , token AnonIs *> ((makeTerm1 .) . invert Expression.Equal <$ token AnonNot <|> pure ((makeTerm1 .) . Expression.Equal)) - ]) - where invert cons a b = Expression.Not (makeTerm1 (cons a b)) - -notOperator :: Assignment (Term Loc) -notOperator = makeTerm <$> symbol NotOperator <*> children (Expression.Not <$> term expression) - -tuple :: Assignment (Term Loc) -tuple = makeTerm <$> symbol Tuple <*> children (Literal.Tuple <$> manyTerm expression) - -unaryOperator :: Assignment (Term Loc) -unaryOperator = symbol UnaryOperator >>= \ location -> arithmetic location <|> bitwise location <|> children ( symbol AnonPlus *> term expression ) - where - arithmetic location = makeTerm location . Expression.Negate <$> children ( symbol AnonMinus *> term expression ) - bitwise location = makeTerm location . Expression.Complement <$> children ( symbol AnonTilde *> term expression ) - -binaryOperator :: Assignment (Term Loc) -binaryOperator = makeTerm' <$> symbol BinaryOperator <*> children (infixTerm expression (term expression) - [ (inject .) . Expression.Plus <$ symbol AnonPlus - , (inject .) . Expression.Minus <$ symbol AnonMinus - , (inject .) . Expression.Times <$ symbol AnonStar - , (inject .) . Expression.Times <$ symbol AnonAt -- Matrix multiplication, TODO: May not want to assign to Expression.Times. - , (inject .) . Expression.DividedBy <$ symbol AnonSlash - , (inject .) . Expression.FloorDivision <$ symbol AnonSlashSlash - , (inject .) . Expression.Modulo <$ symbol AnonPercent - , (inject .) . Expression.Power <$ symbol AnonStarStar - , (inject .) . Expression.BOr <$ symbol AnonPipe - , (inject .) . Expression.BAnd <$ symbol AnonAmpersand - , (inject .) . Expression.BXOr <$ symbol AnonCaret - , (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle - , (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle - ]) - -booleanOperator :: Assignment (Term Loc) -booleanOperator = makeTerm' <$> symbol BooleanOperator <*> children (infixTerm expression (term expression) - [ (inject .) . Expression.And <$ symbol AnonAnd - , (inject .) . Expression.Or <$ symbol AnonOr - ]) - -assignment' :: Assignment (Term Loc) -assignment' = makeAssignment <$> symbol Assignment <*> children ((,,) <$> term expressionList <*> optional (symbol Type *> children (term expression)) <*> term rvalue) - <|> makeTerm' <$> symbol AugmentedAssignment <*> children (infixTerm expressionList (term rvalue) - [ assign Expression.Plus <$ symbol AnonPlusEqual - , assign Expression.Minus <$ symbol AnonMinusEqual - , assign Expression.Times <$ symbol AnonStarEqual - , assign Expression.Times <$ symbol AnonAtEqual -- Matrix multiplication assignment. TODO: May not want to assign to Expression.Times. - , assign Expression.Power <$ symbol AnonStarStarEqual - , assign Expression.DividedBy <$ symbol AnonSlashEqual - , assign Expression.DividedBy <$ symbol AnonSlashSlashEqual - , assign Expression.BOr <$ symbol AnonPipeEqual - , assign Expression.BAnd <$ symbol AnonAmpersandEqual - , assign Expression.Modulo <$ symbol AnonPercentEqual - , assign Expression.RShift <$ symbol AnonRAngleRAngleEqual - , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual - , assign Expression.BXOr <$ symbol AnonCaretEqual - ]) - where rvalue = expressionList <|> assignment' <|> yield <|> emptyTerm - makeAssignment loc (lhs, maybeType, rhs) = makeTerm loc (Statement.Assignment (maybeToList maybeType) lhs rhs) - assign :: (f :< Python.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum Python.Syntax (Term Loc) - assign c l r = inject (Statement.AugmentedAssignment (makeTerm1 (c l r))) - -yield :: Assignment (Term Loc) -yield = makeTerm <$> symbol Yield <*> (Statement.Yield <$> children (term ( expression <|> emptyTerm ))) - -identifier :: Assignment (Term Loc) -identifier = makeTerm <$> (symbol Identifier <|> symbol DottedName) <*> (Syntax.Identifier . name <$> source) - -set :: Assignment (Term Loc) -set = makeTerm <$> symbol Set <*> children (Literal.Set <$> manyTerm expression) - -dictionary :: Assignment (Term Loc) -dictionary = makeTerm <$> symbol Dictionary <*> children (Literal.Hash <$> manyTerm expression) - -pair :: Assignment (Term Loc) -pair = makeTerm' <$> symbol Pair <*> children (infixTerm expression (term expression) [ (inject .) . Literal.KeyValue <$ symbol AnonColon ]) - -list' :: Assignment (Term Loc) -list' = makeTerm <$> symbol List <*> children (Literal.Array <$> manyTerm expression) - -string :: Assignment (Term Loc) -string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source) - -concatenatedString :: Assignment (Term Loc) -concatenatedString = makeTerm <$> symbol ConcatenatedString <*> children (manyTerm string) - -float :: Assignment (Term Loc) -float = makeTerm <$> symbol Float <*> (Literal.Float <$> source) - -integer :: Assignment (Term Loc) -integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source) - -comment :: Assignment (Term Loc) -comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) - -import' :: Assignment (Term Loc) -import' = makeTerm'' <$> symbol ImportStatement <*> children (manyTerm (aliasedImport <|> plainImport)) - <|> makeTerm <$> symbol ImportFromStatement <*> children (Python.Syntax.Import <$> importPath <*> (wildcard <|> some (aliasImportSymbol <|> importSymbol))) - <|> makeTerm <$> symbol FutureImportStatement <*> children (Python.Syntax.FutureImport <$> some (aliasImportSymbol <|> importSymbol)) - where - -- `import a as b` - aliasedImport = makeTerm <$> symbol AliasedImport <*> children (Python.Syntax.QualifiedAliasedImport <$> importPath <*> expression) - -- `import a` - plainImport = makeTerm <$> symbol DottedName <*> children (Python.Syntax.QualifiedImport <$> NonEmpty.some1 identifier) - -- `from a import foo ` - importSymbol = makeNameAliasPair <$> (symbol Identifier <|> symbol DottedName) <*> (mkIdentifier <$> location <*> source) - -- `from a import foo as bar` - aliasImportSymbol = makeTerm <$> symbol AliasedImport <*> children (Python.Syntax.Alias <$> identifier <*> identifier) - -- `from a import *` - wildcard = symbol WildcardImport *> (name <$> source) $> [] - - importPath = importDottedName <|> importRelative - importDottedName = symbol DottedName *> children (qualifiedName <$> NonEmpty.some1 identifierSource) - importRelative = symbol RelativeImport *> children (relativeQualifiedName <$> importPrefix <*> ((symbol DottedName *> children (many identifierSource)) <|> pure [])) - importPrefix = symbol ImportPrefix *> source - identifierSource = symbol Identifier *> source - - makeNameAliasPair location alias = makeTerm location (Python.Syntax.Alias alias alias) - mkIdentifier location source = makeTerm location (Syntax.Identifier (name source)) - -assertStatement :: Assignment (Term Loc) -assertStatement = makeTerm <$> symbol AssertStatement <*> children (Expression.Call [] <$> (makeTerm <$> symbol AnonAssert <*> (Syntax.Identifier . name <$> source)) <*> manyTerm expression <*> emptyTerm) - -printStatement :: Assignment (Term Loc) -printStatement = do - location <- symbol PrintStatement - children $ do - print <- term printKeyword - term (redirectCallTerm location print <|> printCallTerm location print) - where - printKeyword = makeTerm <$> symbol AnonPrint <*> (Syntax.Identifier . name <$> source) - redirectCallTerm location identifier = makeTerm location <$ symbol Chevron <*> (flip Python.Syntax.Redirect <$> children (term expression) <*> term (printCallTerm location identifier)) - printCallTerm location identifier = makeTerm location <$> (Expression.Call [] identifier <$> manyTerm expression <*> emptyTerm) - -nonlocalStatement :: Assignment (Term Loc) -nonlocalStatement = makeTerm <$> symbol NonlocalStatement <*> children (Expression.Call [] <$> term (makeTerm <$> symbol AnonNonlocal <*> (Syntax.Identifier . name <$> source)) <*> manyTerm expression <*> emptyTerm) - -globalStatement :: Assignment (Term Loc) -globalStatement = makeTerm <$> symbol GlobalStatement <*> children (Expression.Call [] <$> term (makeTerm <$> symbol AnonGlobal <*> (Syntax.Identifier . name <$> source)) <*> manyTerm expression <*> emptyTerm) - -await :: Assignment (Term Loc) -await = makeTerm <$> symbol Await <*> children (Expression.Call [] <$> term (makeTerm <$> symbol AnonAwait <*> (Syntax.Identifier . name <$> source)) <*> manyTerm expression <*> emptyTerm) - -returnStatement :: Assignment (Term Loc) -returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> term (expressionList <|> emptyTerm)) - -deleteStatement :: Assignment (Term Loc) -deleteStatement = makeTerm <$> symbol DeleteStatement <*> children (Expression.Call [] <$> term deleteIdentifier <* symbol ExpressionList <*> children (manyTerm expression) <*> emptyTerm) - where deleteIdentifier = makeTerm <$> symbol AnonDel <*> (Syntax.Identifier . name <$> source) - -raiseStatement :: Assignment (Term Loc) -raiseStatement = makeTerm <$> symbol RaiseStatement <*> children (Statement.Throw <$> expressions) - -ifStatement :: Assignment (Term Loc) -ifStatement = makeTerm <$> symbol IfStatement <*> children if' - where - if' = Statement.If <$> term expression <*> thenClause <*> (elseClause <|> emptyTerm) - thenClause = makeTerm'' <$> location <*> manyTermsTill expression (void (symbol ElseClause) <|> void (symbol ElifClause) <|> eof) - elseClause = makeTerm'' <$> location <*> many (comment <|> elif <|> else') - elif = makeTerm <$> symbol ElifClause <*> children if' - else' = symbol ElseClause *> children expressions - -execStatement :: Assignment (Term Loc) -execStatement = makeTerm <$> symbol ExecStatement <*> children (Expression.Call [] <$> term (makeTerm <$> location <*> (Syntax.Identifier . name <$> source)) <*> manyTerm (string <|> expression) <*> emptyTerm) - -passStatement :: Assignment (Term Loc) -passStatement = makeTerm <$> symbol PassStatement <*> (Statement.NoOp <$> emptyTerm <* advance) - -breakStatement :: Assignment (Term Loc) -breakStatement = makeTerm <$> symbol BreakStatement <*> (Statement.Break <$> emptyTerm <* advance) - -continueStatement :: Assignment (Term Loc) -continueStatement = makeTerm <$> symbol ContinueStatement <*> (Statement.Continue <$> emptyTerm <* advance) - -memberAccess :: Assignment (Term Loc) -memberAccess = makeTerm <$> symbol Attribute <*> children (Expression.MemberAccess <$> term expression <*> identifier) - -subscript :: Assignment (Term Loc) -subscript = makeTerm <$> symbol Subscript <*> children (Expression.Subscript <$> term expression <*> manyTerm expression) - -slice :: Assignment (Term Loc) -slice = makeTerm <$> symbol Slice <*> children - (Expression.Enumeration <$> ((emptyTerm <* token AnonColon) <|> (term expression <* token AnonColon)) - <*> ((emptyTerm <* token AnonColon) <|> (term expression <* token AnonColon) <|> (term expression <|> emptyTerm)) - <*> (term expression <|> emptyTerm)) - -call :: Assignment (Term Loc) -call = makeTerm <$> symbol Call <*> children (Expression.Call [] <$> term (identifier <|> expression) <*> (symbol ArgumentList *> children (manyTerm expression) <|> someTerm comprehension) <*> emptyTerm) - -boolean :: Assignment (Term Loc) -boolean = makeTerm <$> token Grammar.True <*> pure Literal.true - <|> makeTerm <$> token Grammar.False <*> pure Literal.false - -none :: Assignment (Term Loc) -none = makeTerm <$> symbol None <*> (Literal.Null <$ rawSource) - -comprehension :: Assignment (Term Loc) -comprehension = makeTerm <$> symbol ListComprehension <*> children (Declaration.Comprehension <$> term expression <*> expressions) - <|> makeTerm <$> symbol GeneratorExpression <*> children (Declaration.Comprehension <$> term expression <*> expressions) - <|> makeTerm <$> symbol SetComprehension <*> children (Declaration.Comprehension <$> term expression <*> expressions) - <|> makeTerm <$> symbol DictionaryComprehension <*> children (Declaration.Comprehension <$> term expression <*> expressions) - -forInClause :: Assignment (Term Loc) -forInClause = symbol ForInClause *> children expressions - -variables :: Assignment (Term Loc) -variables = symbol Variables *> children expressions - -ifClause :: Assignment (Term Loc) -ifClause = symbol IfClause *> children expressions - -conditionalExpression :: Assignment (Term Loc) -conditionalExpression = makeTerm <$> symbol ConditionalExpression <*> children (flip Statement.If <$> term expression <*> term expression <*> expressions) - - --- Helpers - --- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] -manyTerm term = many (contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)) - -someTerm :: Assignment (Term Loc) -> Assignment [Term Loc] -someTerm term = some (contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)) - -term :: Assignment (Term Loc) -> Assignment (Term Loc) -term term = contextualize comment (postContextualize comment term) - -term' :: Assignment (Term Loc) -> Assignment (Term Loc) -term' term = contextualize comment' (postContextualize comment' term) - where comment' = choice [ comment, symbol AnonLambda *> empty ] - --- | Match a left-associated infix chain of terms, optionally followed by comments. Like 'chainl1' but assigning comment nodes automatically. -chainl1Term :: Assignment (Term Loc) -> Assignment (Term Loc -> Term Loc -> Term Loc) -> Assignment (Term Loc) -chainl1Term expr op = term' expr `chainl1` op - --- | Match a series of terms or comments until a delimiter is matched. -manyTermsTill :: Assignment (Term Loc) -> Assignment b -> Assignment [Term Loc] -manyTermsTill step end = manyTill (step <|> comment) end - --- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment (Term Loc) - -> Assignment (Term Loc) - -> [Assignment (Term Loc -> Term Loc -> Sum Python.Syntax (Term Loc))] - -> Assignment (Sum Python.Syntax (Term Loc)) -infixTerm = infixContext comment diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs deleted file mode 100644 index d193f2fc5e..0000000000 --- a/src/Language/Python/Syntax.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -module Language.Python.Syntax (module Language.Python.Syntax) where - -import Control.Lens.Getter -import Data.Aeson hiding (object) -import Data.Foldable -import Data.Functor.Classes -import Data.Functor.Classes.Generic -import Data.Hashable -import Data.Hashable.Lifted -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map.Strict as Map -import Data.Maybe.Exts -import Data.Text (Text) -import qualified Data.Text as T -import Data.Traversable -import GHC.Generics (Generic, Generic1) -import System.FilePath.Posix - -import Control.Abstract.Heap -import Control.Abstract.ScopeGraph hiding (Import) -import Data.Abstract.BaseError -import Data.Abstract.Evaluatable -import Data.Abstract.Module -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import qualified Data.Language as Language -import Source.Span -import qualified System.Path as Path - -data QualifiedName - = QualifiedName (NonEmpty FilePath) - | RelativeQualifiedName FilePath (Maybe QualifiedName) - deriving (Eq, Generic, Hashable, Ord, Show, ToJSON) - -qualifiedName :: NonEmpty Text -> QualifiedName -qualifiedName xs = QualifiedName (T.unpack <$> xs) - -relativeQualifiedName :: Text -> [Text] -> QualifiedName -relativeQualifiedName prefix [] = RelativeQualifiedName (T.unpack prefix) Nothing -relativeQualifiedName prefix paths = RelativeQualifiedName (T.unpack prefix) (Just (qualifiedName (NonEmpty.fromList paths))) - --- Python module resolution. --- https://docs.python.org/3/reference/import.html#importsystem --- --- TODO: Namespace packages --- --- Regular packages resolution: --- --- parent/ --- __init__.py --- one/ --- __init__.py --- two/ --- __init__.py --- three/ --- __init__.py --- --- `import parent.one` will implicitly execute: --- `parent/__init__.py` and --- `parent/one/__init__.py` --- Subsequent imports of `parent.two` or `parent.three` will execute --- `parent/two/__init__.py` and --- `parent/three/__init__.py` respectively. -resolvePythonModules :: ( Has (Modules address value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - , Has Trace sig m - ) - => QualifiedName - -> Evaluator term address value m (NonEmpty ModulePath) -resolvePythonModules q = do - relRootDir <- rootDir q <$> currentModule - for (moduleNames q) $ \relPath -> do - x <- search (Path.toString relRootDir) relPath - x <$ traceResolve relPath x - where - rootDir (QualifiedName _) ModuleInfo{..} = Path.toAbsRel Path.currentDir -- overall rootDir of the Package. - rootDir (RelativeQualifiedName n _) ModuleInfo{..} = upDir numDots (Path.takeDirectory modulePath) - where numDots = pred (length n) - upDir n dir | n <= 0 = dir - | otherwise = maybe dir (upDir (pred n)) $ Path.takeSuperDirectory dir - - moduleNames (QualifiedName qualifiedName) = NonEmpty.scanl1 () qualifiedName - moduleNames (RelativeQualifiedName x Nothing) = error $ "importing from '" <> show x <> "' is not implemented" - moduleNames (RelativeQualifiedName _ (Just paths)) = moduleNames paths - - search rootDir x = do - trace ("searching for " <> show x <> " in " <> show rootDir) - let path = normalise (rootDir normalise x) - let searchPaths = Path.absRel <$> [ path "__init__.py" - , path <.> ".py" - ] - modulePath <- resolve searchPaths - maybeM (throwResolutionError $ NotFoundError (Path.absRel path) searchPaths Language.Python) modulePath - -data Alias a = Alias { aliasValue :: a, aliasName :: a} - deriving (Generic1, Foldable, FreeVariables1, Functor, Hashable1, Traversable) - -instance Eq1 Alias where liftEq = genericLiftEq -instance Ord1 Alias where liftCompare = genericLiftCompare -instance Show1 Alias where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 Alias where - liftDeclaredName declaredName = declaredName . aliasValue - liftDeclaredAlias declaredAlias = declaredAlias . aliasName - -instance Evaluatable Alias where - --- | Import declarations (symbols are added directly to the calling environment). --- --- If the list of symbols is empty copy everything to the calling environment. -data Import a = Import { importFrom :: QualifiedName, importSymbols :: ![a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Import where liftEq = genericLiftEq -instance Ord1 Import where liftCompare = genericLiftCompare -instance Show1 Import where liftShowsPrec = genericLiftShowsPrec - -newtype FutureImport a = FutureImport { futureImportSymbols :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 FutureImport where liftEq = genericLiftEq -instance Ord1 FutureImport where liftCompare = genericLiftCompare -instance Show1 FutureImport where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FutureImport where - --- from a import b -instance Evaluatable Import where - -- from . import moduleY -- aliasValue = moduleY, aliasName = moduleY - -- from . import moduleY as moduleZ -- aliasValue = moduleY, aliasName = moduleZ - -- This is a bit of a special case in the syntax as this actually behaves like a qualified relative import. - eval _ _ (Import (RelativeQualifiedName n Nothing) [aliasTerm]) = do - aliasValue' <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm) - path <- NonEmpty.last <$> resolvePythonModules (RelativeQualifiedName n (Just (qualifiedName (formatName aliasValue' :| [])))) - ((moduleScope, moduleFrame), _) <- require path - - -- Construct a proxy scope containing an import edge to the imported module's last returned scope. - importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ]) - - -- Construct an object frame. - let scopeMap = Map.singleton moduleScope moduleFrame - aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap) - - -- Add declaration of the alias name to the current scope (within our current module). - aliasName <- maybeM (throwNoNameError aliasTerm) (declaredAlias aliasTerm) - declare (Declaration aliasName) Default Public (aliasTerm^.span_) ScopeGraph.UnqualifiedImport (Just importScope) - -- Retrieve the frame slot for the new declaration. - aliasSlot <- lookupSlot (Declaration aliasName) - assign aliasSlot =<< object aliasFrame - - unit - - -- from a import b - -- from a import b as c - -- from a import * - -- from .moduleY import b - eval _ _ (Import name xs) = do - modulePaths <- resolvePythonModules name - - -- Eval parent modules first - for_ (NonEmpty.init modulePaths) require - - -- Last module path is the one we want to import - let path = NonEmpty.last modulePaths - ((moduleScope, moduleFrame), _) <- require path - if Prelude.null xs then do - insertImportEdge moduleScope - insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - else do - let scopeEdges = Map.singleton ScopeGraph.Import [ moduleScope ] - scopeAddress <- newScope scopeEdges - - let frameLinks = Map.singleton moduleScope moduleFrame - frameAddress <- newFrame scopeAddress (Map.singleton ScopeGraph.Import frameLinks) - - insertImportEdge scopeAddress - insertFrameLink ScopeGraph.Import (Map.singleton scopeAddress frameAddress) - - withScope moduleScope . - for_ xs $ \aliasTerm -> do - aliasName <- maybeM (throwNoNameError aliasTerm) (declaredAlias aliasTerm) - aliasValue <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm) - if aliasValue /= aliasName then do - insertImportReference (Reference aliasName) (aliasTerm^.span_) ScopeGraph.Identifier (Declaration aliasValue) scopeAddress - else - pure () - - unit - -newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Traversable) - -instance Eq1 QualifiedImport where liftEq = genericLiftEq -instance Ord1 QualifiedImport where liftCompare = genericLiftCompare -instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec -instance Hashable1 QualifiedImport where liftHashWithSalt = foldl - --- import a.b.c -instance Evaluatable QualifiedImport where - eval _ _ (QualifiedImport qualifiedNames) = do - -- TODO: Consider gensym'ed names for imports. - qualifiedName <- fmap (T.unpack . formatName) <$> traverse (\term -> maybeM (throwNoNameError term) (declaredName term)) qualifiedNames - modulePaths <- resolvePythonModules (QualifiedName qualifiedName) - let namesAndPaths = toList (NonEmpty.zip (NonEmpty.zip qualifiedNames (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName)) modulePaths) - - go namesAndPaths - unit - where - go [] = pure () - go (((nameTerm, name), modulePath) : namesAndPaths) = do - scopeAddress <- newScope mempty - declare (Declaration name) Default Public (nameTerm^.span_) ScopeGraph.QualifiedImport (Just scopeAddress) - aliasSlot <- lookupSlot (Declaration name) - -- a.b.c - withScope scopeAddress $ - mkScopeMap modulePath (\scopeMap -> do - objFrame <- newFrame scopeAddress (Map.singleton ScopeGraph.Import scopeMap) - val <- object objFrame - assign aliasSlot val - - withFrame objFrame $ do - let (namePaths, rest) = List.partition ((== name) . snd . fst) namesAndPaths - for_ namePaths $ \(_, modulePath) -> do - mkScopeMap modulePath $ \scopeMap -> do - withFrame objFrame $ do - insertFrameLink ScopeGraph.Import scopeMap - go rest) - mkScopeMap modulePath fun = do - ((moduleScope, moduleFrame), _) <- require modulePath - insertImportEdge moduleScope - fun (Map.singleton moduleScope moduleFrame) - -data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportFrom :: QualifiedName, qualifiedAliasedImportAlias :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq -instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare -instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec - --- import a.b.c as e -instance Evaluatable QualifiedAliasedImport where - eval _ _ (QualifiedAliasedImport name aliasTerm) = do - modulePaths <- resolvePythonModules name - - span <- ask @Span - scopeAddress <- newScope mempty - alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm) - declare (Declaration alias) Default Public span ScopeGraph.QualifiedAliasedImport (Just scopeAddress) - objFrame <- newFrame scopeAddress mempty - val <- object objFrame - aliasSlot <- lookupSlot (Declaration alias) - assign aliasSlot val - - withScopeAndFrame objFrame . - for_ modulePaths $ \modulePath -> do - ((moduleScope, moduleFrame), _) <- require modulePath - insertImportEdge moduleScope - insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - - unit - --- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell) -data Ellipsis a = Ellipsis - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Ellipsis where liftEq = genericLiftEq -instance Ord1 Ellipsis where liftCompare = genericLiftCompare -instance Show1 Ellipsis where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Ellipsis -instance Evaluatable Ellipsis - -data Redirect a = Redirect { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Redirect where liftEq = genericLiftEq -instance Ord1 Redirect where liftCompare = genericLiftCompare -instance Show1 Redirect where liftShowsPrec = genericLiftShowsPrec - --- TODO: Implement Eval instance for Redirect -instance Evaluatable Redirect diff --git a/src/Language/Python/Term.hs b/src/Language/Python/Term.hs deleted file mode 100644 index 9a11945c5f..0000000000 --- a/src/Language/Python/Term.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, RecordWildCards, TypeFamilies #-} -module Language.Python.Term -( Syntax -, Term(..) -) where - -import Control.Lens.Lens -import Data.Abstract.Declarations -import Data.Abstract.FreeVariables -import Data.Bitraversable -import Data.Coerce -import Data.Foldable (fold) -import Data.Functor.Foldable (Base, Recursive(..)) -import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) -import qualified Data.Sum as Sum -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term -import Data.Traversable -import Language.Python.Syntax as Python.Syntax -import Source.Loc -import Source.Span - -type Syntax = - [ Comment.Comment - , Declaration.Class - , Declaration.Comprehension - , Declaration.Decorator - , Declaration.Function - , Declaration.RequiredParameter - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.Complement - , Expression.Call - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Enumeration - , Expression.ScopeResolution - , Expression.MemberAccess - , Expression.Subscript - , Expression.Member - , Literal.Array - , Literal.Boolean - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.KeyValue - , Literal.Null - , Literal.Set - , Literal.String - , Literal.TextElement - , Literal.Tuple - , Python.Syntax.Alias - , Python.Syntax.Ellipsis - , Python.Syntax.FutureImport - , Python.Syntax.Import - , Python.Syntax.QualifiedImport - , Python.Syntax.QualifiedAliasedImport - , Python.Syntax.Redirect - , Statement.Assignment - , Statement.AugmentedAssignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.Else - , Statement.Finally - , Statement.ForEach - , Statement.If - , Statement.Let - , Statement.NoOp - , Statement.Return - , Statement.Statements - , Statement.Throw - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.Context - , Syntax.Empty - , Syntax.Error - , Syntax.Identifier - , Type.Annotation - , [] - ] - - -newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } - deriving (Eq, Declarations, FreeVariables, Ord, Show) - -instance Term.IsTerm Term where - type Syntax Term = Sum.Sum Syntax - toTermF = coerce - fromTermF = coerce - -instance Foldable Term where - foldMap = foldMapDefault - -instance Functor Term where - fmap = fmapDefault - -instance Traversable Term where - traverse f = go where go = fmap Term . bitraverse f go . getTerm - -instance VertexDeclaration Term where - toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax - -instance Syntax.HasErrors Term where - getErrors = cata $ \ (Term.In Loc{..} syntax) -> - maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) - - -type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann - -instance Recursive (Term ann) where - project = getTerm - -instance HasSpan ann => HasSpan (Term ann) where - span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) - {-# INLINE span_ #-} diff --git a/src/Language/Ruby/Assignment.hs b/src/Language/Ruby/Assignment.hs deleted file mode 100644 index 1ce62849d8..0000000000 --- a/src/Language/Ruby/Assignment.hs +++ /dev/null @@ -1,499 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Language.Ruby.Assignment -( assignment -, Ruby.Syntax -, Grammar -, Ruby.Term(..) -) where - -import Analysis.Name (name) -import Assigning.Assignment hiding (Assignment, Error) -import qualified Assigning.Assignment as Assignment -import Control.Monad hiding (unless) -import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..)) -import Data.List.NonEmpty (some1) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe -import Data.Sum -import Data.Syntax - ( contextualize - , emptyTerm - , handleError - , infixContext - , makeTerm - , makeTerm' - , makeTerm'' - , makeTerm1 - , parseError - , postContextualize - ) -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Directive as Directive -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Text as Text -import Language.Ruby.Grammar as Grammar -import qualified Language.Ruby.Syntax as Ruby.Syntax -import Language.Ruby.Term as Ruby - -type Assignment = Assignment.Assignment Grammar - --- | Assignment from AST in Ruby’s grammar onto a program in Ruby’s syntax. -assignment :: Assignment (Term Loc) -assignment = handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> many expression) <|> parseError - -expression :: Assignment (Term Loc) -expression = term (handleError (choice expressionChoices)) - -expressionChoices :: [Assignment (Term Loc)] -expressionChoices = - [ alias - , assignment' - , begin - , beginBlock - , binary - , block - , call - , case' - , class' - , conditional - , emptyStatement - , endBlock - , for - , heredoc - , identifier - , if' - , then' - , lambda - , literal - , method - , methodCall - , mk Break Statement.Break - , mk Break' Statement.Break - , mk Next Statement.Continue - , mk Next' Statement.Continue - , mk Redo Statement.Retry - , mk Retry Statement.Retry - , mk Return Statement.Return - , mk Return' Statement.Return - , mk Yield Statement.Yield - , mk Yield' Statement.Yield - , module' - , pair - , parenthesizedExpressions - , parseError - , rescue - , scopeResolution - , self - , singletonClass - , singletonMethod - , subscript - , unary - , undef - , unless - , until' - , while' - , do' - ] - where - mk s construct = makeTerm <$> symbol s <*> children ((construct .) . fromMaybe <$> emptyTerm <*> optional ((symbol ArgumentList <|> symbol ArgumentList') *> children expressions)) - -expressions :: Assignment (Term Loc) -expressions = makeTerm'' <$> location <*> many expression - -parenthesizedExpressions :: Assignment (Term Loc) -parenthesizedExpressions = makeTerm'' <$> symbol ParenthesizedStatements <*> children (many expression) - -withExtendedScope :: Assignment a -> Assignment a -withExtendedScope inner = do - locals <- getLocals - result <- inner - putLocals locals - pure result - -withNewScope :: Assignment a -> Assignment a -withNewScope inner = withExtendedScope $ do - putLocals [] - inner - --- Looks up identifiers in the list of locals to determine vcall vs. local identifier. -identifier :: Assignment (Term Loc) -identifier = - vcallOrLocal - <|> zsuper - <|> mk Constant - <|> mk InstanceVariable - <|> mk ClassVariable - <|> mk GlobalVariable - <|> mk Operator - <|> mk Setter - <|> mk Uninterpreted - <|> symbol HashSplatArgument *> children expression - <|> symbol SplatArgument *> children expression - <|> symbol BlockArgument *> children expression - where - mk s = makeTerm <$> symbol s <*> (Syntax.Identifier . name <$> source) - zsuper = makeTerm <$> symbol Super <*> (Ruby.Syntax.ZSuper <$ source) - vcallOrLocal = do - loc <- symbol Identifier - ident <- source - locals <- getLocals - case ident of - "__FILE__" -> pure $ makeTerm loc Directive.File - "__LINE__" -> pure $ makeTerm loc Directive.Line - _ -> do - let identTerm = makeTerm loc (Syntax.Identifier (name ident)) - if ident `elem` locals - then pure identTerm - else pure $ makeTerm loc (Ruby.Syntax.Send Nothing (Just identTerm) [] Nothing) - -self :: Assignment (Term Loc) -self = makeTerm <$> symbol Self <*> (Expression.This <$ source) - --- TODO: Handle interpolation in all literals that support it (strings, regexes, symbols, subshells, etc). -literal :: Assignment (Term Loc) -literal = - makeTerm <$> token Grammar.True <*> pure Literal.true - <|> makeTerm <$> token Grammar.False <*> pure Literal.false - <|> makeTerm <$> token Grammar.Nil <*> pure Literal.Null - <|> makeTerm <$> symbol Grammar.Integer <*> (Literal.Integer <$> source) - <|> makeTerm <$> symbol Grammar.Float <*> (Literal.Float <$> source) - <|> makeTerm <$> symbol Grammar.Rational <*> (Literal.Rational <$> source) - <|> makeTerm <$> symbol Grammar.Complex <*> (Literal.Complex <$> source) - -- TODO: Do we want to represent the difference between .. and ... - <|> makeTerm <$> symbol Range <*> children (Expression.Enumeration <$> expression <*> expression <*> emptyTerm) - <|> makeTerm <$> symbol Array <*> children (Literal.Array <$> many expression) - <|> makeTerm <$> symbol StringArray <*> children (Literal.Array <$> many expression) - <|> makeTerm <$> symbol SymbolArray <*> children (Literal.Array <$> many expression) - <|> makeTerm <$> symbol Hash <*> children (Literal.Hash <$> many expression) - <|> makeTerm <$> symbol Subshell <*> (Literal.TextElement <$> source) - <|> string - <|> symbol' - <|> makeTerm <$> symbol Character <*> (Literal.Character <$> source) - <|> makeTerm <$> symbol ChainedString <*> children (many (makeTerm <$> symbol String <*> (Literal.TextElement <$> source))) - <|> makeTerm <$> symbol Regex <*> (Literal.Regex <$> source) - - where - string :: Assignment (Term Loc) - string = makeTerm' <$> (symbol String <|> symbol BareString) <*> - (children (inject . Literal.String <$> some (interpolation <|> escapeSequence)) <|> inject . Literal.TextElement <$> source) - - symbol' :: Assignment (Term Loc) - symbol' = makeTerm' <$> (symbol Symbol <|> symbol Symbol' <|> symbol BareSymbol) <*> - (children (inject . Literal.Symbol <$> some interpolation) <|> inject . Literal.SymbolElement <$> source) - -interpolation :: Assignment (Term Loc) -interpolation = makeTerm <$> symbol Interpolation <*> children (Literal.InterpolationElement <$> expression) - -escapeSequence :: Assignment (Term Loc) -escapeSequence = makeTerm <$> symbol EscapeSequence <*> (Literal.EscapeSequence <$> source) - -heredoc :: Assignment (Term Loc) -heredoc = makeTerm <$> symbol HeredocBeginning <*> (Literal.TextElement <$> source) - <|> makeTerm <$> symbol HeredocBody <*> children (some (interpolation <|> escapeSequence <|> heredocEnd)) - where heredocEnd = makeTerm <$> symbol HeredocEnd <*> (Literal.TextElement <$> source) - -beginBlock :: Assignment (Term Loc) -beginBlock = makeTerm <$> symbol BeginBlock <*> children (Statement.ScopeEntry <$> many expression) - -endBlock :: Assignment (Term Loc) -endBlock = makeTerm <$> symbol EndBlock <*> children (Statement.ScopeExit <$> many expression) - -class' :: Assignment (Term Loc) -class' = makeTerm <$> symbol Class <*> (withNewScope . children) (Ruby.Syntax.Class <$> expression <*> optional superclass <*> expressions) - where - superclass :: Assignment (Term Loc) - superclass = symbol Superclass *> children expression - -singletonClass :: Assignment (Term Loc) -singletonClass = makeTerm <$> symbol SingletonClass <*> (withNewScope . children) (Ruby.Syntax.Class <$> expression <*> pure Nothing <*> expressions) - -module' :: Assignment (Term Loc) -module' = makeTerm <$> symbol Module <*> (withNewScope . children) (Ruby.Syntax.Module <$> expression <*> many expression) - -scopeResolution :: Assignment (Term Loc) -scopeResolution = makeTerm <$> symbol ScopeResolution <*> children (Expression.ScopeResolution <$> NonEmpty.some1 expression) - -parameter :: Assignment (Term Loc) -parameter = postContextualize comment (term uncontextualizedParameter) - where - uncontextualizedParameter = - lhsIdent - <|> splatParameter - <|> hashSplatParameter - <|> blockParameter - <|> keywordParameter - <|> optionalParameter - <|> makeTerm <$> symbol DestructuredParameter <*> children (many parameter) - -- splat and hash splat arguments can be unnamed. we don't currently - -- support unnamed arguments in the term syntax, so the use of emptyTerm - -- here is a huge hack. what we should be able to do is return a Nothing - -- for the argument name for splats and hash splats. TODO fix me: - mkSplat s = symbol s *> children (lhsIdent <|> emptyTerm) - splatParameter = mkSplat SplatParameter - hashSplatParameter = mkSplat HashSplatParameter - blockParameter = symbol BlockParameter *> children lhsIdent - -- we don't yet care about default expressions for optional (including - -- keyword) parameters, but we need to match on them to prevent errors: - keywordParameter = symbol KeywordParameter *> children (lhsIdent <* optional expression) - optionalParameter = symbol OptionalParameter *> children (lhsIdent <* expression) - -publicAccessControl :: ScopeGraph.AccessControl -publicAccessControl = ScopeGraph.Public - -method :: Assignment (Term Loc) -method = makeTerm <$> symbol Method <*> (withNewScope . children) (Declaration.Method [] <$> emptyTerm <*> methodSelector <*> params <*> expressions' <*> pure publicAccessControl) - where params = symbol MethodParameters *> children (many parameter) <|> pure [] - expressions' = makeTerm <$> location <*> many expression - -singletonMethod :: Assignment (Term Loc) -singletonMethod = makeTerm <$> symbol SingletonMethod <*> (withExtendedScope . children) (Declaration.Method [] <$> expression <*> methodSelector <*> params <*> expressions <*> pure publicAccessControl) - where params = symbol MethodParameters *> children (many parameter) <|> pure [] - -lambda :: Assignment (Term Loc) -lambda = makeTerm <$> symbol Lambda <*> (withExtendedScope . children) ( - Declaration.Function [] <$> emptyTerm - <*> ((symbol BlockParameters <|> symbol LambdaParameters) *> children (many parameter) <|> pure []) - <*> expressions) - -block :: Assignment (Term Loc) -block = makeTerm <$> symbol DoBlock <*> scopedBlockChildren - <|> makeTerm <$> symbol Block <*> scopedBlockChildren - where scopedBlockChildren = withExtendedScope blockChildren - blockChildren = children (Declaration.Function [] <$> emptyTerm <*> params <*> expressions) - params = symbol BlockParameters *> children (many parameter) <|> pure [] - -comment :: Assignment (Term Loc) -comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) - -alias :: Assignment (Term Loc) -alias = makeTerm <$> symbol Alias <*> children (Expression.Call [] <$> name' <*> some expression <*> emptyTerm) - where name' = makeTerm <$> location <*> (Syntax.Identifier . name <$> source) - -undef :: Assignment (Term Loc) -undef = makeTerm <$> symbol Undef <*> children (Expression.Call [] <$> name' <*> some expression <*> emptyTerm) - where name' = makeTerm <$> location <*> (Syntax.Identifier . name <$> source) - -if' :: Assignment (Term Loc) -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)) - 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 Loc) -then' = postContextualize comment (symbol Then *> children expressions) - -unless :: Assignment (Term Loc) -unless = makeTerm <$> symbol Unless <*> children (Statement.If <$> invert expression <*> expressions' <*> (else' <|> emptyTerm)) - <|> makeTerm <$> symbol UnlessModifier <*> children (flip Statement.If <$> expression <*> invert expression <*> emptyTerm) - where expressions' = makeTerm <$> location <*> manyTermsTill expression (void (symbol Else) <|> eof) - else' = postContextualize comment (symbol Else *> children expressions) - -while' :: Assignment (Term Loc) -while' = - makeTerm <$> symbol While <*> children (Statement.While <$> expression <*> expressions) - <|> makeTerm <$> symbol WhileModifier <*> children (flip Statement.While <$> expression <*> expression) - -do' :: Assignment (Term Loc) -do' = symbol Do *> children expressions - -until' :: Assignment (Term Loc) -until' = - makeTerm <$> symbol Until <*> children (Statement.While <$> invert expression <*> expressions) - <|> makeTerm <$> symbol UntilModifier <*> children (flip Statement.While <$> expression <*> invert expression) - -for :: Assignment (Term Loc) -for = makeTerm <$> symbol For <*> children (Statement.ForEach <$> (makeTerm <$> location <*> manyTermsTill expression (symbol In)) <*> inClause <*> expressions) - where inClause = symbol In *> children expression - -case' :: Assignment (Term Loc) -case' = makeTerm <$> symbol Case <*> children (Statement.Match <$> (symbol When *> emptyTerm <|> expression) <*> whens) - where - whens = makeTerm <$> location <*> many (when' <|> else' <|> expression) - when' = makeTerm <$> symbol When <*> children (Statement.Pattern <$> (makeTerm <$> location <*> some pattern') <*> whens) - pattern' = postContextualize comment (symbol Pattern *> children ((symbol SplatArgument *> children expression) <|> expression)) - else' = postContextualize comment (symbol Else *> children expressions) - -subscript :: Assignment (Term Loc) -subscript = makeTerm <$> symbol ElementReference <*> children (Expression.Subscript <$> expression <*> many expression) - -pair :: Assignment (Term Loc) -pair = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> expression <*> (expression <|> emptyTerm)) - -args :: Assignment [Term Loc] -args = (symbol ArgumentList <|> symbol ArgumentList') *> children (many expression) <|> many expression - -methodCall :: Assignment (Term Loc) -methodCall = makeTerm' <$> (symbol MethodCall <|> symbol MethodCall') <*> children (require <|> load <|> send) - where - send = inject <$> ((regularCall <|> funcCall <|> scopeCall <|> dotCall) <*> optional block) - - funcCall = Ruby.Syntax.Send Nothing <$> selector <*> args - regularCall = symbol Call *> children (Ruby.Syntax.Send <$> (Just <$> postContextualize heredoc expression) <*> selector) <*> args - scopeCall = symbol ScopeResolution *> children (Ruby.Syntax.Send <$> (Just <$> expression) <*> selector) <*> args - dotCall = symbol Call *> children (Ruby.Syntax.Send <$> (Just <$> term expression) <*> pure Nothing <*> args) - - selector = Just <$> term methodSelector - require = inject <$> (symbol Identifier *> do - s <- rawSource - guard (s `elem` ["require", "require_relative"]) - Ruby.Syntax.Require (s == "require_relative") <$> nameExpression) - load = inject <$ symbol Identifier <*> do - s <- rawSource - guard (s == "load") - (symbol ArgumentList <|> symbol ArgumentList') *> children (Ruby.Syntax.Load <$> expression <*> optional expression) - nameExpression = (symbol ArgumentList <|> symbol ArgumentList') *> children expression - -methodSelector :: Assignment (Term Loc) -methodSelector = makeTerm <$> symbols <*> (Syntax.Identifier <$> (name <$> source)) - where - symbols = symbol Identifier - <|> symbol Constant - <|> symbol Operator - <|> symbol Setter - <|> symbol Super -- TODO(@charliesome): super calls are *not* method calls and need to be assigned into their own syntax terms - -call :: Assignment (Term Loc) -call = makeTerm <$> symbol Call <*> children ( - (Ruby.Syntax.Send <$> (Just <$> term expression) <*> (Just <$> methodSelector) <*> pure [] <*> pure Nothing) <|> - (Ruby.Syntax.Send <$> (Just <$> term expression) <*> pure Nothing <*> args <*> pure Nothing)) - -rescue :: Assignment (Term Loc) -rescue = rescue' - <|> makeTerm <$> symbol RescueModifier <*> children (Statement.Try <$> expression <*> many (makeTerm <$> location <*> (Statement.Catch <$> expression <*> emptyTerm))) - <|> makeTerm <$> symbol Ensure <*> children (Statement.Finally <$> expressions) - <|> makeTerm <$> symbol Else <*> children (Statement.Else <$> emptyTerm <*> expressions) - where - rescue' = makeTerm <$> symbol Rescue <*> children (Statement.Catch <$> exceptions <*> (rescue' <|> expressions)) - exceptions = makeTerm <$> location <*> many ex - ex = makeTerm <$> symbol Exceptions <*> children (many expression) - <|> makeTerm <$> symbol ExceptionVariable <*> children (many expression) - -begin :: Assignment (Term Loc) -begin = makeTerm <$> symbol Begin <*> children (Statement.Try <$> expressions <*> many rescue) - -assignment' :: Assignment (Term Loc) -assignment' = makeTerm <$> symbol Assignment <*> children (Ruby.Syntax.Assignment [] <$> lhs <*> rhs) - <|> makeTerm' <$> symbol OperatorAssignment <*> children (infixTerm lhs expression - [ assign Expression.Plus <$ symbol AnonPlusEqual - , assign Expression.Minus <$ symbol AnonMinusEqual - , assign Expression.Times <$ symbol AnonStarEqual - , assign Expression.Power <$ symbol AnonStarStarEqual - , assign Expression.DividedBy <$ symbol AnonSlashEqual - , assign Expression.Or <$ symbol AnonPipePipeEqual - , assign Expression.BOr <$ symbol AnonPipeEqual - , assign Expression.And <$ symbol AnonAmpersandAmpersandEqual - , assign Expression.BAnd <$ symbol AnonAmpersandEqual - , assign Expression.Modulo <$ symbol AnonPercentEqual - , assign Expression.RShift <$ symbol AnonRAngleRAngleEqual - , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual - , assign Expression.BXOr <$ symbol AnonCaretEqual - ]) - where - assign :: (f :< Ruby.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum Ruby.Syntax (Term Loc) - assign c l r = inject (Statement.AugmentedAssignment (makeTerm1 (c l r))) - - lhs = makeTerm <$> symbol LeftAssignmentList <*> children (many expr) <|> expr - rhs = makeTerm <$> symbol RightAssignmentList <*> children (many expression) <|> expression - expr = makeTerm <$> symbol RestAssignment <*> restAssign - <|> makeTerm <$> symbol DestructuredLeftAssignment <*> children (many expr) - <|> lhsIdent - <|> expression - - restAssign = do - locals <- getLocals - ident <- Text.dropWhile (== '*') <$> source - putLocals (ident : locals) - pure $ Syntax.Identifier (name ident) - -lhsIdent :: Assignment (Term Loc) -lhsIdent = do - locals <- getLocals - loc <- symbol Identifier - ident <- source - putLocals (ident : locals) - pure $ makeTerm loc (Syntax.Identifier (name ident)) - -unary :: Assignment (Term Loc) -unary = symbol Unary >>= \ location -> - makeTerm location . Expression.Complement <$> children ( symbol AnonTilde *> expression ) - <|> 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 <|> symbol AnonMinus' <|> symbol AnonMinus'') *> expression ) - <|> children ( symbol AnonPlus *> expression ) - --- TODO: Distinguish `===` from `==` ? -binary :: Assignment (Term Loc) -binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expression - [ (inject .) . Expression.Plus <$ symbol AnonPlus - , (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 <|> symbol AnonSlash') - , (inject .) . Expression.Modulo <$ symbol AnonPercent - , (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand - , (inject .) . Ruby.Syntax.LowPrecedenceAnd <$ symbol AnonAnd - , (inject .) . Expression.BAnd <$ symbol AnonAmpersand - , (inject .) . Expression.Or <$ symbol AnonPipePipe - , (inject .) . Ruby.Syntax.LowPrecedenceOr <$ symbol AnonOr - , (inject .) . Expression.BOr <$ symbol AnonPipe - , (inject .) . Expression.BXOr <$ symbol AnonCaret - -- TODO: AnonEqualEqualEqual corresponds to Ruby's "case equality" - -- function, which (unless overridden) is true if b is an instance - -- of or inherits from a. We need a custom equality operator - -- for this situation. - , (inject .) . Expression.Equal <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual) - , (inject .) . invert Expression.Equal <$ symbol AnonBangEqual - , (inject .) . Expression.LShift <$ (symbol AnonLAngleLAngle <|> symbol AnonLAngleLAngle') - , (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle - , (inject .) . Expression.Comparison <$ symbol AnonLAngleEqualRAngle - , (inject .) . Expression.LessThan <$ symbol AnonLAngle - , (inject .) . Expression.GreaterThan <$ symbol AnonRAngle - , (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual - , (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual - , (inject .) . Expression.Matches <$ symbol AnonEqualTilde - , (inject .) . Expression.NotMatches <$ symbol AnonBangTilde - ]) - where invert cons a b = Expression.Not (makeTerm1 (cons a b)) - -conditional :: Assignment (Term Loc) -conditional = makeTerm <$> symbol Conditional <*> children (Statement.If <$> expression <*> expression <*> expression) - -emptyStatement :: Assignment (Term Loc) -emptyStatement = makeTerm <$> symbol EmptyStatement <*> (Syntax.Empty <$ rawSource <|> pure Syntax.Empty) - - --- Helpers - -invert :: Assignment (Term Loc) -> Assignment (Term Loc) -invert term = makeTerm <$> location <*> fmap Expression.Not term - --- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -term :: Assignment (Term Loc) -> Assignment (Term Loc) -term term = contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 (comment <|> heredocBody) <*> emptyTerm) - where - heredocBody = makeTerm <$> symbol HeredocBody <*> children (some (interpolation <|> escapeSequence <|> heredocEnd)) - heredocEnd = makeTerm <$> symbol HeredocEnd <*> (Literal.TextElement <$> source) - --- | Match a series of terms or comments until a delimiter is matched. -manyTermsTill :: Assignment (Term Loc) -> Assignment b -> Assignment [Term Loc] -manyTermsTill step end = manyTill (step <|> comment) end - --- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment (Term Loc) - -> Assignment (Term Loc) - -> [Assignment (Term Loc -> Term Loc -> Sum Ruby.Syntax (Term Loc))] - -> Assignment (Sum Ruby.Syntax (Term Loc)) -infixTerm = infixContext comment diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs deleted file mode 100644 index 09ffda5b69..0000000000 --- a/src/Language/Ruby/Syntax.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -module Language.Ruby.Syntax (module Language.Ruby.Syntax) where - -import Analysis.Name as Name -import Control.Abstract as Abstract hiding (Load, String) -import Control.Monad -import Data.Abstract.BaseError -import Data.Abstract.Evaluatable -import qualified Data.Abstract.Module as M -import Data.Abstract.Path -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Functor.Classes -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import qualified Data.Language as Language -import Data.List.NonEmpty (nonEmpty) -import qualified Data.Map.Strict as Map -import Data.Maybe.Exts -import Data.Semigroup.App -import Data.Semigroup.Foldable -import Data.Text (Text) -import qualified Data.Text as T -import Data.Traversable (for) -import GHC.Generics (Generic1) -import qualified System.Path as Path - --- TODO: Fully sort out ruby require/load mechanics --- --- require "json" -resolveRubyName :: ( Has (Modules address value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - ) - => Text - -> Evaluator term address value m M.ModulePath -resolveRubyName name = do - let name' = cleanNameOrPath name - let paths = [name' Path.<.> "rb"] - modulePath <- resolve paths - maybeM (throwResolutionError $ NotFoundError (Path.toFileDir name') paths Language.Ruby) modulePath - --- load "/root/src/file.rb" -resolveRubyPath :: ( Has (Modules address value) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - ) - => Text - -> Evaluator term address value m M.ModulePath -resolveRubyPath path = do - let name' = cleanNameOrPath path - modulePath <- resolve [name'] - maybeM (throwResolutionError $ NotFoundError (Path.toFileDir name') [name'] Language.Ruby) modulePath - -cleanNameOrPath :: Text -> Path.AbsRelFile -cleanNameOrPath = Path.absRel . T.unpack . dropRelativePrefix . stripQuotes - -data Send a = Send { sendReceiver :: Maybe a, sendSelector :: Maybe a, sendArgs :: [a], sendBlock :: Maybe a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Send where liftEq = genericLiftEq -instance Ord1 Send where liftCompare = genericLiftCompare -instance Show1 Send where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Send where - eval eval _ Send{..} = do - sel <- case sendSelector of - Just sel -> maybeM (throwNoNameError sel) (declaredName sel) - Nothing -> - pure (Name.name "call") - - let self = deref =<< lookupSlot (Declaration __self) - lhsValue <- maybe self eval sendReceiver - lhsFrame <- Abstract.scopedEnvironment lhsValue - - let callFunction = do - span <- ask @Span - reference (Reference sel) span ScopeGraph.Call (Declaration sel) - func <- deref =<< lookupSlot (Declaration sel) - args <- traverse eval sendArgs - boundFunc <- bindThis lhsValue func - call boundFunc args -- TODO pass through sendBlock - maybe callFunction (`withScopeAndFrame` callFunction) lhsFrame - -data Require a = Require { requireRelative :: Bool, requirePath :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Require where liftEq = genericLiftEq -instance Ord1 Require where liftCompare = genericLiftCompare -instance Show1 Require where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Require where - eval eval _ (Require _ x) = do - name <- eval x >>= asString - path <- resolveRubyName name - traceResolve name path - ((moduleScope, moduleFrame), v) <- doRequire path - insertImportEdge moduleScope - insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - pure v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require - -doRequire :: ( Has (Boolean value) sig m - , Has (Modules address value) sig m - ) - => M.ModulePath - -> Evaluator term address value m ((address, address), value) -doRequire path = do - result <- lookupModule path - case result of - Nothing -> (,) . fst <$> load path <*> boolean True - Just (scopeAndFrame, _) -> (scopeAndFrame, ) <$> boolean False - - -data Load a = Load { loadPath :: a, loadWrap :: Maybe a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Load where liftEq = genericLiftEq -instance Ord1 Load where liftCompare = genericLiftCompare -instance Show1 Load where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Load where - eval eval _ (Load x Nothing) = do - path <- eval x >>= asString - doLoad path False - eval eval _ (Load x (Just wrap)) = do - path <- eval x >>= asString - shouldWrap <- eval wrap >>= asBool - doLoad path shouldWrap - -doLoad :: ( Has (Boolean value) sig m - , Has (Modules address value) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader ModuleInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - , Has (State (ScopeGraph.ScopeGraph address)) sig m - , Has (State (Heap address address value)) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has Trace sig m - , Ord address - ) - => Text - -> Bool - -> Evaluator term address value m value -doLoad path shouldWrap = do - path' <- resolveRubyPath path - traceResolve path path' - (moduleScope, moduleFrame) <- fst <$> load path' - unless shouldWrap $ do - insertImportEdge moduleScope - insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - boolean Prelude.True -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load - --- TODO: autoload - -data Class a = Class { classIdentifier :: !a, classSuperClass :: !(Maybe a), classBody :: !a } - deriving (Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1) - -instance Eq1 Class where liftEq = genericLiftEq -instance Ord1 Class where liftCompare = genericLiftCompare -instance Show1 Class where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Class where - eval eval _ Class{..} = do - (name, relation) <- case declaredName classIdentifier of - Just name -> pure (name, Default) - _ -> gensym >>= \name -> pure (name, Gensym) - span <- ask @Span - currentScope' <- currentScope - - let declaration = Declaration name - maybeSlot <- maybeLookupDeclaration declaration - - case maybeSlot of - Just slot -> do - classVal <- deref slot - maybeFrame <- scopedEnvironment classVal - case maybeFrame of - Just classFrame -> withScopeAndFrame classFrame (eval classBody) - Nothing -> throwEvalError (DerefError classVal) - Nothing -> do - let classSuperclasses = maybeToList classSuperClass - superScopes <- for classSuperclasses $ \superclass -> do - name <- maybeM (throwNoNameError superclass) (declaredName superclass) - scope <- associatedScope (Declaration name) - slot <- lookupSlot (Declaration name) - superclassFrame <- scopedEnvironment =<< deref slot - pure $ case (scope, superclassFrame) of - (Just scope, Just frame) -> Just (scope, frame) - _ -> Nothing - - let superclassEdges = (Superclass, ) . pure . fst <$> catMaybes superScopes - current = (Lexical, ) <$> pure (pure currentScope') - edges = Map.fromList (superclassEdges <> current) - classScope <- newScope edges - declare (Declaration name) relation Public span ScopeGraph.Class (Just classScope) - - let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes)) - childFrame <- newFrame classScope frameEdges - - withScopeAndFrame childFrame $ do - void $ eval classBody - - classSlot <- lookupSlot (Declaration name) - assign classSlot =<< klass (Declaration name) childFrame - - unit - -instance Declarations1 Class where - liftDeclaredName declaredName = declaredName . classIdentifier - - -data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Module where liftEq = genericLiftEq -instance Ord1 Module where liftCompare = genericLiftCompare -instance Show1 Module where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Module where - eval eval _ Module{..} = do - (name, relation) <- case declaredName moduleIdentifier of - Just name -> pure (name, Default) - _ -> gensym >>= \name -> pure (name, Gensym) - span <- ask @Span - currentScope' <- currentScope - - let declaration = Declaration name - moduleBody = maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty moduleStatements) - maybeSlot <- maybeLookupDeclaration declaration - - case maybeSlot of - Just slot -> do - moduleVal <- deref slot - maybeFrame <- scopedEnvironment moduleVal - case maybeFrame of - Just moduleFrame -> do - withScopeAndFrame moduleFrame moduleBody - Nothing -> throwEvalError (DerefError moduleVal) - Nothing -> do - let edges = Map.singleton Lexical [ currentScope' ] - classScope <- newScope edges - declare (Declaration name) relation Public span ScopeGraph.Module (Just classScope) - - currentFrame' <- currentFrame - let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame') - childFrame <- newFrame classScope frameEdges - - withScopeAndFrame childFrame (void moduleBody) - - moduleSlot <- lookupSlot (Declaration name) - assign moduleSlot =<< klass (Declaration name) childFrame - - unit - -instance Declarations1 Module where - liftDeclaredName declaredName = declaredName . moduleIdentifier - - -data LowPrecedenceAnd a = LowPrecedenceAnd { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 LowPrecedenceAnd where liftEq = genericLiftEq -instance Ord1 LowPrecedenceAnd where liftCompare = genericLiftCompare -instance Show1 LowPrecedenceAnd where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LowPrecedenceAnd where - -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands - eval eval _ t = go (fmap eval t) where - go (LowPrecedenceAnd a b) = do - cond <- a - ifthenelse cond b (pure cond) - - -data LowPrecedenceOr a = LowPrecedenceOr { lhs :: a, rhs :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 LowPrecedenceOr where liftEq = genericLiftEq -instance Ord1 LowPrecedenceOr where liftCompare = genericLiftCompare -instance Show1 LowPrecedenceOr where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LowPrecedenceOr where - -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands - eval eval _ t = go (fmap eval t) where - go (LowPrecedenceOr a b) = do - cond <- a - ifthenelse cond (pure cond) b - -data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Assignment where liftEq = genericLiftEq -instance Ord1 Assignment where liftCompare = genericLiftCompare -instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 Assignment where - liftDeclaredName declaredName Assignment{..} = declaredName assignmentTarget - -instance Evaluatable Assignment where - eval eval ref Assignment{..} = do - (lhsName, relation) <- case declaredName assignmentTarget of - Just name -> pure (name, Default) - _ -> gensym >>= \name -> pure (name, Gensym) - maybeSlot <- maybeLookupDeclaration (Declaration lhsName) - assignmentSpan <- ask @Span - maybe (declare (Declaration lhsName) relation Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot - - lhs <- ref assignmentTarget - rhs <- eval assignmentValue - - case declaredName assignmentValue of - Just rhsName -> do - assocScope <- associatedScope (Declaration rhsName) - case assocScope of - Just assocScope' -> do - objectScope <- newScope (Map.singleton Import [ assocScope' ]) - putSlotDeclarationScope lhs (Just objectScope) -- TODO: not sure if this is right - Nothing -> - pure () - Nothing -> - pure () - assign lhs rhs - pure rhs - - --- | A call to @super@ without parentheses in Ruby is known as "zsuper", which has --- the semantics of invoking @super()@ but implicitly passing the current function's --- arguments to the @super()@ invocation. -data ZSuper a = ZSuper - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ZSuper where liftEq = genericLiftEq -instance Ord1 ZSuper where liftCompare = genericLiftCompare -instance Show1 ZSuper where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ZSuper diff --git a/src/Language/Ruby/Term.hs b/src/Language/Ruby/Term.hs deleted file mode 100644 index 316405b0b5..0000000000 --- a/src/Language/Ruby/Term.hs +++ /dev/null @@ -1,153 +0,0 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, RecordWildCards, TypeFamilies #-} -module Language.Ruby.Term -( Syntax -, Term(..) -) where - -import Control.Lens.Lens -import Data.Abstract.Declarations -import Data.Abstract.FreeVariables -import Data.Bitraversable -import Data.Coerce -import Data.Foldable (fold) -import Data.Functor.Foldable (Base, Recursive(..)) -import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) -import qualified Data.Sum as Sum -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Directive as Directive -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Term as Term -import Data.Traversable -import qualified Language.Ruby.Syntax as Ruby.Syntax -import Source.Loc -import Source.Span - -type Syntax = - [ Comment.Comment - , Declaration.Function - , Declaration.Method - , Directive.File - , Directive.Line - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.Complement - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.Call - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Enumeration - , Expression.Matches - , Expression.NotMatches - , Expression.MemberAccess - , Expression.ScopeResolution - , Expression.Subscript - , Expression.Member - , Expression.This - , Literal.Array - , Literal.Boolean - , Literal.Character - , Literal.Complex - , Literal.EscapeSequence - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.InterpolationElement - , Literal.KeyValue - , Literal.Null - , Literal.Rational - , Literal.Regex - , Literal.String - , Literal.Symbol - , Literal.SymbolElement - , Literal.TextElement - , Ruby.Syntax.Assignment - , Statement.AugmentedAssignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.Else - , Statement.Finally - , Statement.ForEach - , Statement.If - , Statement.Match - , Statement.Pattern - , Statement.Retry - , Statement.Return - , Statement.ScopeEntry - , Statement.ScopeExit - , Statement.Statements - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.Context - , Syntax.Empty - , Syntax.Error - , Syntax.Identifier - , Ruby.Syntax.Class - , Ruby.Syntax.Load - , Ruby.Syntax.LowPrecedenceAnd - , Ruby.Syntax.LowPrecedenceOr - , Ruby.Syntax.Module - , Ruby.Syntax.Require - , Ruby.Syntax.Send - , Ruby.Syntax.ZSuper - , [] - ] - - -newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } - deriving (Eq, Declarations, FreeVariables, Ord, Show) - -instance Term.IsTerm Term where - type Syntax Term = Sum.Sum Syntax - toTermF = coerce - fromTermF = coerce - -instance Foldable Term where - foldMap = foldMapDefault - -instance Functor Term where - fmap = fmapDefault - -instance Traversable Term where - traverse f = go where go = fmap Term . bitraverse f go . getTerm - -instance VertexDeclaration Term where - toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax - -instance Syntax.HasErrors Term where - getErrors = cata $ \ (Term.In Loc{..} syntax) -> - maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) - - -type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann - -instance Recursive (Term ann) where - project = getTerm - -instance HasSpan ann => HasSpan (Term ann) where - span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) - {-# INLINE span_ #-} diff --git a/src/Language/TSX/Assignment.hs b/src/Language/TSX/Assignment.hs deleted file mode 100644 index 2fd186bb08..0000000000 --- a/src/Language/TSX/Assignment.hs +++ /dev/null @@ -1,799 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Language.TSX.Assignment -( assignment -, TSX.Syntax -, Grammar -, TSX.Term(..) -) where - -import Analysis.Name (name) -import Assigning.Assignment hiding (Assignment, Error) -import qualified Assigning.Assignment as Assignment -import Control.Monad -import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..)) -import Data.Foldable -import Data.Function -import Data.List.NonEmpty (nonEmpty, some1) -import Data.Maybe -import Data.Sum -import Data.Syntax - ( contextualize - , emptyTerm - , handleError - , infixContext - , makeTerm - , makeTerm' - , makeTerm'' - , makeTerm1 - , parseError - , postContextualize - ) -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import qualified Language.TSX.Syntax as TSX.Syntax -import Language.TSX.Term as TSX -import qualified Language.TypeScript.Resolution as TypeScript.Resolution -import Language.TSX.Grammar as Grammar - -type Assignment = Assignment.Assignment Grammar - --- | Assignment from AST in TSX’s grammar onto a program in TSX’s syntax. -assignment :: Assignment (Term Loc) -assignment = handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> manyTerm statement) <|> parseError - -expression :: Assignment (Term Loc) -expression = handleError everything - where - everything = choice [ - asExpression, - nonNullExpression', - importAlias', - internalModule, - super, - object, - array, - jsxElement', - jsxFragment, - class', - function, - arrowFunction, - assignmentExpression, - augmentedAssignmentExpression, - awaitExpression, - unaryExpression, - binaryExpression, - ternaryExpression, - updateExpression, - callExpression, - memberExpression, - newExpression, - parenthesizedExpression, - subscriptExpression, - yieldExpression, - this, - number, - string, - templateString, - regex, - true, - false, - null', - undefined', - identifier - ] - -undefined' :: Assignment (Term Loc) -undefined' = makeTerm <$> symbol Grammar.Undefined <*> (TSX.Syntax.Undefined <$ rawSource) - -assignmentExpression :: Assignment (Term Loc) -assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) <*> expression) - -augmentedAssignmentExpression :: Assignment (Term Loc) -augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) (term expression) [ - assign Expression.Plus <$ symbol AnonPlusEqual - , assign Expression.Minus <$ symbol AnonMinusEqual - , assign Expression.Times <$ symbol AnonStarEqual - , assign Expression.DividedBy <$ symbol AnonSlashEqual - , assign Expression.Modulo <$ symbol AnonPercentEqual - , assign Expression.BXOr <$ symbol AnonCaretEqual - , assign Expression.BAnd <$ symbol AnonAmpersandEqual - , assign Expression.RShift <$ symbol AnonRAngleRAngleEqual - , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual - , assign Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngleEqual - , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual - , assign Expression.BOr <$ symbol AnonPipeEqual ]) - where assign :: (f :< TSX.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum TSX.Syntax (Term Loc) - assign c l r = inject (Statement.AugmentedAssignment (makeTerm1 (c l r))) - - -awaitExpression :: Assignment (Term Loc) -awaitExpression = makeTerm <$> symbol Grammar.AwaitExpression <*> children (Expression.Await <$> term expression) - -unaryExpression :: Assignment (Term Loc) -unaryExpression = symbol Grammar.UnaryExpression >>= \ loc -> - makeTerm loc . Expression.Not <$> children (symbol AnonBang *> term expression) - <|> makeTerm loc . Expression.Complement <$> children (symbol AnonTilde *> term expression) - <|> makeTerm loc . Expression.Negate <$> children ((symbol AnonMinus <|> symbol AnonPlus) *> term expression) - <|> makeTerm loc . Expression.Typeof <$> children (symbol AnonTypeof *> term expression) - <|> makeTerm loc . Expression.Void <$> children (symbol AnonVoid *> term expression) - <|> makeTerm loc . Expression.Delete <$> children (symbol AnonDelete *> term expression) - -ternaryExpression :: Assignment (Term Loc) -ternaryExpression = makeTerm <$> symbol Grammar.TernaryExpression <*> children (Statement.If <$> term expression <*> term expression <*> term expression) - -memberExpression :: Assignment (Term Loc) -memberExpression = makeTerm <$> (symbol Grammar.MemberExpression <|> symbol Grammar.MemberExpression') <*> children (Expression.MemberAccess <$> term expression <*> propertyIdentifier) - -newExpression :: Assignment (Term Loc) -newExpression = makeTerm <$> symbol Grammar.NewExpression <*> children (Expression.New <$> term constructableExpression <*> (typeArguments' <|> emptyTerm) <*> (arguments <|> pure [])) - -constructableExpression :: Assignment (Term Loc) -constructableExpression = choice [ - this - , identifier - , number - , string - , templateString - , regex - , true - , false - , null' - , undefined' - , object - , array - , function - , arrowFunction - , class' - , parenthesizedExpression - , subscriptExpression - , memberExpression - , metaProperty - , newExpression - ] - -metaProperty :: Assignment (Term Loc) -metaProperty = makeTerm <$> symbol Grammar.MetaProperty <*> (TSX.Syntax.MetaProperty <$ rawSource) - -updateExpression :: Assignment (Term Loc) -updateExpression = makeTerm <$> symbol Grammar.UpdateExpression <*> children (TSX.Syntax.Update <$> term expression) - -yieldExpression :: Assignment (Term Loc) -yieldExpression = makeTerm <$> symbol Grammar.YieldExpression <*> children (Statement.Yield <$> term (expression <|> emptyTerm)) - -this :: Assignment (Term Loc) -this = makeTerm <$> symbol Grammar.This <*> (Expression.This <$ rawSource) - -regex :: Assignment (Term Loc) -regex = makeTerm <$> symbol Grammar.Regex <*> (Literal.Regex <$> source) - -null' :: Assignment (Term Loc) -null' = makeTerm <$> symbol Null <*> (Literal.Null <$ rawSource) - -abstractClass :: Assignment (Term Loc) -abstractClass = makeTerm <$> symbol Grammar.AbstractClassDeclaration <*> children (TSX.Syntax.AbstractClass <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> (classHeritage' <|> pure []) <*> classBodyStatements) - -abstractMethodSignature :: Assignment (Term Loc) -abstractMethodSignature = makeSignature <$> symbol Grammar.AbstractMethodSignature <*> children ((,,) <$> accessibilityModifier' <*> term propertyName <*> callSignatureParts) - where makeSignature loc (modifier, propertyName, (typeParams, params, annotation)) = makeTerm loc (TSX.Syntax.AbstractMethodSignature [typeParams, annotation] propertyName params modifier) - -classHeritage' :: Assignment [Term Loc] -classHeritage' = symbol Grammar.ClassHeritage *> children ((mappend `on` toList) <$> optional (term extendsClause) <*> optional (term implementsClause')) - -extendsClause :: Assignment (Term Loc) -extendsClause = makeTerm <$> symbol Grammar.ExtendsClause <*> children (TSX.Syntax.ExtendsClause <$> manyTerm (typeReference <|> expression)) - -typeReference :: Assignment (Term Loc) -typeReference = typeIdentifier <|> nestedTypeIdentifier <|> genericType - -implementsClause' :: Assignment (Term Loc) -implementsClause' = makeTerm <$> symbol Grammar.ImplementsClause <*> children (TSX.Syntax.ImplementsClause <$> manyTerm ty) - -super :: Assignment (Term Loc) -super = makeTerm <$> symbol Grammar.Super <*> (TSX.Syntax.Super <$ rawSource) - -asExpression :: Assignment (Term Loc) -asExpression = makeTerm <$> symbol AsExpression <*> children (Expression.Cast <$> term expression <*> term (ty <|> templateString)) - -templateString :: Assignment (Term Loc) -templateString = makeTerm <$> symbol TemplateString <*> children (Literal.String <$> manyTerm templateSubstitution) - -templateSubstitution :: Assignment (Term Loc) -templateSubstitution = symbol TemplateSubstitution *> children (term expressions) - -nonNullExpression' :: Assignment (Term Loc) -nonNullExpression' = makeTerm <$> symbol Grammar.NonNullExpression <*> children (Expression.NonNullExpression <$> term expression) - -importAlias' :: Assignment (Term Loc) -importAlias' = makeTerm <$> symbol Grammar.ImportAlias <*> children (TSX.Syntax.ImportAlias <$> term identifier <*> term (identifier <|> nestedIdentifier)) - -number :: Assignment (Term Loc) -number = makeTerm <$> symbol Grammar.Number <*> (Literal.Float <$> source) - -string :: Assignment (Term Loc) -string = makeTerm <$> symbol Grammar.String <*> (Literal.TextElement <$> source) - -true :: Assignment (Term Loc) -true = makeTerm <$> symbol Grammar.True <*> (Literal.true <$ rawSource) - -false :: Assignment (Term Loc) -false = makeTerm <$> symbol Grammar.False <*> (Literal.false <$ rawSource) - -identifier :: Assignment (Term Loc) -identifier = makeTerm <$> symbol Identifier <*> (Syntax.Identifier . name <$> source) - -class' :: Assignment (Term Loc) -class' = makeClass <$> (symbol Class <|> symbol ClassDeclaration) <*> children ((,,,,) <$> manyTerm decorator - <*> (term typeIdentifier <|> emptyTerm) - <*> (symbol TypeParameters *> children (manyTerm typeParameter') <|> pure []) - <*> (classHeritage' <|> pure []) - <*> classBodyStatements) - where makeClass loc (decorators, expression, typeParams, classHeritage, statements) = makeTerm loc (Declaration.Class (decorators <> typeParams) expression classHeritage statements) - -object :: Assignment (Term Loc) -object = makeTerm <$> (symbol Object <|> symbol ObjectPattern) <*> children (Literal.Hash <$> manyTerm (pair <|> spreadElement <|> methodDefinition <|> assignmentPattern <|> shorthandPropertyIdentifier)) - -array :: Assignment (Term Loc) -array = makeTerm <$> (symbol Array <|> symbol ArrayPattern) <*> children (Literal.Array <$> manyTerm (expression <|> spreadElement)) - -jsxElement' :: Assignment (Term Loc) -jsxElement' = choice [ jsxElement, jsxSelfClosingElement ] - -jsxElement :: Assignment (Term Loc) -jsxElement = makeTerm <$> symbol Grammar.JsxElement <*> children (TSX.Syntax.JsxElement <$> term jsxOpeningElement' <*> manyTerm jsxChild <*> term jsxClosingElement') - -jsxFragment :: Assignment (Term Loc) -jsxFragment = makeTerm <$> symbol Grammar.JsxFragment <*> children (TSX.Syntax.JsxFragment <$> manyTerm jsxChild) - -jsxChild :: Assignment (Term Loc) -jsxChild = choice [ jsxElement', jsxExpression', jsxText ] - -jsxSelfClosingElement :: Assignment (Term Loc) -jsxSelfClosingElement = makeTerm <$> symbol Grammar.JsxSelfClosingElement <*> children (TSX.Syntax.JsxSelfClosingElement <$> term jsxElementName <*> manyTerm jsxAttribute') - -jsxAttribute' :: Assignment (Term Loc) -jsxAttribute' = jsxAttribute <|> jsxExpression' - -jsxOpeningElement' :: Assignment (Term Loc) -jsxOpeningElement' = makeTerm <$> symbol Grammar.JsxOpeningElement <*> children (TSX.Syntax.JsxOpeningElement <$> term jsxElementName <*> term (typeArguments' <|> emptyTerm) <*> manyTerm jsxAttribute') - -jsxElementName :: Assignment (Term Loc) -jsxElementName = choice [ identifier, nestedIdentifier, jsxNamespaceName ] - -jsxNamespaceName :: Assignment (Term Loc) -jsxNamespaceName = makeTerm <$> symbol Grammar.JsxNamespaceName <*> children (TSX.Syntax.JsxNamespaceName <$> identifier <*> identifier) - -jsxExpression' :: Assignment (Term Loc) -jsxExpression' = makeTerm <$> symbol Grammar.JsxExpression <*> children (TSX.Syntax.JsxExpression <$> term (expressions <|> spreadElement <|> emptyTerm)) - -jsxText :: Assignment (Term Loc) -jsxText = makeTerm <$> symbol Grammar.JsxText <*> (TSX.Syntax.JsxText <$> source) - -jsxClosingElement' :: Assignment (Term Loc) -jsxClosingElement' = makeTerm <$> symbol Grammar.JsxClosingElement <*> children (TSX.Syntax.JsxClosingElement <$> term jsxElementName) - -jsxAttribute :: Assignment (Term Loc) -jsxAttribute = makeTerm <$> symbol Grammar.JsxAttribute <*> children (TSX.Syntax.JsxAttribute <$> term (propertyIdentifier <|> jsxNamespaceName) <*> (term jsxAttributeValue <|> emptyTerm)) - where jsxAttributeValue = choice [ string, jsxExpression', jsxElement', jsxFragment ] - -propertyIdentifier :: Assignment (Term Loc) -propertyIdentifier = makeTerm <$> symbol PropertyIdentifier <*> (Syntax.Identifier . name <$> source) - -sequenceExpression :: Assignment (Term Loc) -sequenceExpression = makeTerm <$> symbol Grammar.SequenceExpression <*> children (Expression.SequenceExpression <$> term expression <*> term expressions) - -expressions :: Assignment (Term Loc) -expressions = annotatedExpression <|> expression <|> sequenceExpression - -annotatedExpression :: Assignment (Term Loc) -annotatedExpression = mkAnnotated <$> location <*> expression <*> typeAnnotation' - where mkAnnotated loc expr ann = makeTerm loc (TSX.Syntax.AnnotatedExpression expr ann) - -parameter :: Assignment (Term Loc) -parameter = requiredParameter - <|> restParameter - <|> optionalParameter - -accessibilityModifier' :: Assignment ScopeGraph.AccessControl -accessibilityModifier' = (symbol AccessibilityModifier >> children (public <|> protected <|> private)) <|> default' - where public = symbol AnonPublic >> pure ScopeGraph.Public - protected = symbol AnonProtected >> pure ScopeGraph.Protected - private = symbol AnonPrivate >> pure ScopeGraph.Private - default' = pure ScopeGraph.Public - - -destructuringPattern :: Assignment (Term Loc) -destructuringPattern = object <|> array - -spreadElement :: Assignment (Term Loc) -spreadElement = symbol SpreadElement *> children (term expression) - -readonly' :: Assignment (Term Loc) -readonly' = makeTerm <$> symbol Readonly <*> (Type.Readonly <$ rawSource) - -methodDefinition :: Assignment (Term Loc) -methodDefinition = makeMethod <$> - symbol MethodDefinition - <*> children ((,,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> emptyTerm <*> term propertyName <*> callSignatureParts <*> term statementBlock) - where - makeMethod loc (modifier, readonly, receiver, propertyName', (typeParameters', params, ty'), statements) = makeTerm loc (Declaration.Method [readonly, typeParameters', ty'] receiver propertyName' params statements modifier) - -callSignatureParts :: Assignment (Term Loc, [Term Loc], Term Loc) -callSignatureParts = contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> callSignature' <*> many comment) - where - callSignature' = (,,) <$> (term typeParameters <|> emptyTerm) <*> formalParameters <*> (term typeAnnotation' <|> emptyTerm) - contextualize' (cs, (typeParams, formalParams, annotation)) = case nonEmpty cs of - Just cs -> (makeTerm1 (Syntax.Context cs typeParams), formalParams, annotation) - Nothing -> (typeParams, formalParams, annotation) - postContextualize' (typeParams, formalParams, annotation) cs = case nonEmpty cs of - Just cs -> (typeParams, formalParams, makeTerm1 (Syntax.Context cs annotation)) - Nothing -> (typeParams, formalParams, annotation) - -callSignature :: Assignment (Term Loc) -callSignature = makeTerm <$> symbol Grammar.CallSignature <*> children (TSX.Syntax.CallSignature <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional (term typeAnnotation'))) - -constructSignature :: Assignment (Term Loc) -constructSignature = makeTerm <$> symbol Grammar.ConstructSignature <*> children (TSX.Syntax.ConstructSignature <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional (term typeAnnotation'))) - -indexSignature :: Assignment (Term Loc) -indexSignature = makeTerm <$> symbol Grammar.IndexSignature <*> children (TSX.Syntax.IndexSignature <$> term identifier <*> predefinedTy <*> term typeAnnotation') - -methodSignature :: Assignment (Term Loc) -methodSignature = makeMethodSignature <$> symbol Grammar.MethodSignature <*> children ((,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> callSignatureParts) - where makeMethodSignature loc (accessControl, readonly, propertyName, (typeParams, params, annotation)) = makeTerm loc (Declaration.MethodSignature [readonly, typeParams, annotation] propertyName params accessControl) - -formalParameters :: Assignment [Term Loc] -formalParameters = symbol FormalParameters *> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term parameter)) <*> many comment)) - where - contextualize' (cs, formalParams) = case nonEmpty cs of - Just cs -> toList cs <> formalParams - Nothing -> formalParams - postContextualize' formalParams cs = case nonEmpty cs of - Just cs -> formalParams <> toList cs - Nothing -> formalParams - - -decorator :: Assignment (Term Loc) -decorator = makeTerm <$> symbol Grammar.Decorator <*> children (TSX.Syntax.Decorator <$> term (identifier <|> memberExpression <|> callExpression)) - -typeParameters :: Assignment (Term Loc) -typeParameters = makeTerm <$> symbol TypeParameters <*> children (Type.TypeParameters <$> manyTerm typeParameter') - -typeAnnotation' :: Assignment (Term Loc) -typeAnnotation' = makeTerm <$> symbol TypeAnnotation <*> children (TSX.Syntax.Annotation <$> term ty) - -typeParameter' :: Assignment (Term Loc) -typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TSX.Syntax.TypeParameter <$> term typeIdentifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm)) - -defaultType :: Assignment (Term Loc) -defaultType = makeTerm <$> symbol Grammar.DefaultType <*> children (TSX.Syntax.DefaultType <$> term ty) - -constraint :: Assignment (Term Loc) -constraint = makeTerm <$> symbol Grammar.Constraint <*> children (TSX.Syntax.Constraint <$> term ty) - -function :: Assignment (Term Loc) -function = makeFunction <$> (symbol Grammar.Function <|> symbol Grammar.FunctionDeclaration <|> symbol Grammar.GeneratorFunction <|> symbol Grammar.GeneratorFunctionDeclaration) <*> children ((,,) <$> term (identifier <|> emptyTerm) <*> callSignatureParts <*> term statementBlock) - where makeFunction loc (id, (typeParams, params, annotation), statements) = makeTerm loc (Declaration.Function [typeParams, annotation] id params statements) - --- TODO: FunctionSignatures can, but don't have to be ambient functions. -ambientFunction :: Assignment (Term Loc) -ambientFunction = makeAmbientFunction <$> symbol Grammar.FunctionSignature <*> children ((,) <$> term identifier <*> callSignatureParts) - where makeAmbientFunction loc (id, (typeParams, params, annotation)) = makeTerm loc (TSX.Syntax.AmbientFunction [typeParams, annotation] id params) - -ty :: Assignment (Term Loc) -ty = primaryType <|> unionType <|> intersectionType <|> functionTy <|> constructorTy - -primaryType :: Assignment (Term Loc) -primaryType = arrayTy - <|> existentialType - <|> flowMaybeTy - <|> genericType - <|> indexTypeQuery - <|> literalType - <|> lookupType - <|> nestedTypeIdentifier - <|> objectType - <|> parenthesizedTy - <|> predefinedTy - <|> this - <|> tupleType - <|> typeIdentifier - <|> typePredicate - <|> typeQuery - -parenthesizedTy :: Assignment (Term Loc) -parenthesizedTy = makeTerm <$> symbol Grammar.ParenthesizedType <*> children (TSX.Syntax.ParenthesizedType <$> term ty) - -predefinedTy :: Assignment (Term Loc) -predefinedTy = makeTerm <$> symbol Grammar.PredefinedType <*> (TSX.Syntax.PredefinedType <$> source) - -typeIdentifier :: Assignment (Term Loc) -typeIdentifier = makeTerm <$> symbol Grammar.TypeIdentifier <*> (TSX.Syntax.TypeIdentifier <$> source) - -nestedIdentifier :: Assignment (Term Loc) -nestedIdentifier = makeTerm <$> symbol Grammar.NestedIdentifier <*> children (TSX.Syntax.NestedIdentifier <$> term (identifier <|> nestedIdentifier) <*> term identifier) - -nestedTypeIdentifier :: Assignment (Term Loc) -nestedTypeIdentifier = makeTerm <$> symbol Grammar.NestedTypeIdentifier <*> children (TSX.Syntax.NestedTypeIdentifier <$> term (identifier <|> nestedIdentifier) <*> term typeIdentifier) - -genericType :: Assignment (Term Loc) -genericType = makeTerm <$> symbol Grammar.GenericType <*> children (TSX.Syntax.GenericType <$> term (typeIdentifier <|> nestedTypeIdentifier) <*> term typeArguments') - -typeArguments' :: Assignment (Term Loc) -typeArguments' = makeTerm <$> symbol Grammar.TypeArguments <*> children (TSX.Syntax.TypeArguments <$> some (term ty)) - -typePredicate :: Assignment (Term Loc) -typePredicate = makeTerm <$> symbol Grammar.TypePredicate <*> children (TSX.Syntax.TypePredicate <$> term identifier <*> term ty) - -objectType :: Assignment (Term Loc) -objectType = makeTerm <$> symbol Grammar.ObjectType <*> children (TSX.Syntax.ObjectType <$> manyTerm (exportStatement <|> propertySignature <|> callSignature <|> constructSignature <|> indexSignature <|> methodSignature)) - -arrayTy :: Assignment (Term Loc) -arrayTy = makeTerm <$> symbol Grammar.ArrayType <*> children (TSX.Syntax.ArrayType <$> term ty) - -lookupType :: Assignment (Term Loc) -lookupType = makeTerm <$> symbol Grammar.LookupType <*> children (TSX.Syntax.LookupType <$> term (typeIdentifier <|> nestedTypeIdentifier) <*> term ty) - -flowMaybeTy :: Assignment (Term Loc) -flowMaybeTy = makeTerm <$> symbol Grammar.FlowMaybeType <*> children (TSX.Syntax.FlowMaybeType <$> term primaryType) - -typeQuery :: Assignment (Term Loc) -typeQuery = makeTerm <$> symbol Grammar.TypeQuery <*> children (TSX.Syntax.TypeQuery <$> term (identifier <|> nestedIdentifier)) - -indexTypeQuery :: Assignment (Term Loc) -indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TSX.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedTypeIdentifier)) - -existentialType :: Assignment (Term Loc) -existentialType = makeTerm <$> symbol Grammar.ExistentialType <*> (TSX.Syntax.ExistentialType <$> source) - -literalType :: Assignment (Term Loc) -literalType = makeTerm <$> symbol Grammar.LiteralType <*> children (TSX.Syntax.LiteralType <$> term (number <|> string <|> true <|> false)) - -unionType :: Assignment (Term Loc) -unionType = makeTerm <$> symbol UnionType <*> children (TSX.Syntax.Union <$> (term ty <|> emptyTerm) <*> term ty) - -intersectionType :: Assignment (Term Loc) -intersectionType = makeTerm <$> symbol IntersectionType <*> children (TSX.Syntax.Intersection <$> term ty <*> term ty) - -functionTy :: Assignment (Term Loc) -functionTy = makeTerm <$> symbol Grammar.FunctionType <*> children (TSX.Syntax.FunctionType <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty) - -tupleType :: Assignment (Term Loc) -tupleType = makeTerm <$> symbol TupleType <*> children (TSX.Syntax.Tuple <$> manyTerm ty) - -constructorTy :: Assignment (Term Loc) -constructorTy = makeTerm <$> symbol ConstructorType <*> children (TSX.Syntax.Constructor <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty) - -statementTerm :: Assignment (Term Loc) -statementTerm = makeTerm <$> symbol StatementBlock <*> children (Statement.Statements <$> manyTerm statement) - -statementBlock :: Assignment (Term Loc) -statementBlock = makeTerm <$> symbol StatementBlock <*> children (Statement.StatementBlock <$> manyTerm statement) - -classBodyStatements :: Assignment (Term Loc) -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)) - where - contextualize' (cs, formalParams) = case nonEmpty cs of - Just cs -> toList cs <> formalParams - Nothing -> formalParams - postContextualize' formalParams cs = case nonEmpty cs of - Just cs -> formalParams <> toList cs - Nothing -> formalParams - -publicFieldDefinition :: Assignment (Term Loc) -publicFieldDefinition = makeField <$> symbol Grammar.PublicFieldDefinition <*> children ((,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) - where makeField loc (accessControl, readonly, propertyName, annotation, expression) = makeTerm loc (Declaration.PublicFieldDefinition [readonly, annotation] propertyName expression accessControl) - - -statement :: Assignment (Term Loc) -statement = handleError everything - where - everything = choice [ - exportStatement - , importStatement - , debuggerStatement - , expressionStatement' - , declaration - , statementTerm - , ifStatement - , switchStatement - , forStatement - , forInStatement - , whileStatement - , doStatement - , tryStatement - , withStatement - , breakStatement - , continueStatement - , returnStatement - , throwStatement - , hashBang - , emptyStatement - , labeledStatement ] - -forInStatement :: Assignment (Term Loc) -forInStatement = makeTerm <$> symbol ForInStatement <*> children (Statement.ForEach <$> term expression <*> term expression <*> term statement) - -doStatement :: Assignment (Term Loc) -doStatement = makeTerm <$> symbol DoStatement <*> children (flip Statement.DoWhile <$> term statement <*> term parenthesizedExpression) - -continueStatement :: Assignment (Term Loc) -continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (statementIdentifier <|> term emptyTerm)) - -breakStatement :: Assignment (Term Loc) -breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (statementIdentifier <|> term emptyTerm)) - -withStatement :: Assignment (Term Loc) -withStatement = makeTerm <$> symbol WithStatement <*> children (TSX.Syntax.With <$> term parenthesizedExpression <*> term statement) - -returnStatement :: Assignment (Term Loc) -returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expressions <|> term emptyTerm)) - -throwStatement :: Assignment (Term Loc) -throwStatement = makeTerm <$> symbol Grammar.ThrowStatement <*> children (Statement.Throw <$> term expressions) - -hashBang :: Assignment (Term Loc) -hashBang = makeTerm <$> symbol HashBangLine <*> (Comment.HashBang <$> source) - -labeledStatement :: Assignment (Term Loc) -labeledStatement = makeTerm <$> symbol Grammar.LabeledStatement <*> children (TSX.Syntax.LabeledStatement <$> statementIdentifier <*> term statement) - -statementIdentifier :: Assignment (Term Loc) -statementIdentifier = makeTerm <$> symbol StatementIdentifier <*> (Syntax.Identifier . name <$> source) - -importStatement :: Assignment (Term Loc) -importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> children ((,) <$> importClause <*> fromClause) - <|> makeTerm' <$> symbol Grammar.ImportStatement <*> children (requireImport <|> sideEffectImport) - where - -- `import foo = require("./foo")` - requireImport = inject <$> (symbol Grammar.ImportRequireClause *> children (TSX.Syntax.QualifiedAliasedImport <$> term identifier <*> fromClause)) - -- `import "./foo"` - sideEffectImport = inject <$> (TSX.Syntax.SideEffectImport <$> fromClause) - -- `import { bar } from "./foo"` - namedImport = (,) Nothing <$> (symbol Grammar.NamedImports *> children (many importSymbol)) - -- `import defaultMember from "./foo"` - defaultImport = (,) Nothing <$> (pure <$> (makeNameAliasPair <$> rawIdentifier <*> pure Nothing)) - -- `import * as name from "./foo"` - namespaceImport = symbol Grammar.NamespaceImport *> children ((,) . Just <$> term identifier <*> pure []) - - -- Combinations of the above. - importClause = symbol Grammar.ImportClause *> - children ( - (pure <$> namedImport) - <|> (pure <$> namespaceImport) - <|> ((\a b -> [a, b]) <$> defaultImport <*> (namedImport <|> namespaceImport)) - <|> (pure <$> defaultImport)) - - makeImportTerm1 loc from (Just alias, _) = makeTerm loc (TSX.Syntax.QualifiedAliasedImport alias from) - makeImportTerm1 loc from (Nothing, symbols) = makeTerm loc (TSX.Syntax.Import (uncurry TSX.Syntax.Alias <$> symbols) from) - 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 *> (name <$> source) - makeNameAliasPair from (Just alias) = (from, alias) - makeNameAliasPair from Nothing = (from, from) - - -- TODO: Need to validate that inline comments are still handled with this change in assigning to Path and not a Term.Term (Sum TSX.Syntax). - fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source) - -debuggerStatement :: Assignment (Term Loc) -debuggerStatement = makeTerm <$> symbol Grammar.DebuggerStatement <*> (TSX.Syntax.Debugger <$ rawSource) - -expressionStatement' :: Assignment (Term Loc) -expressionStatement' = symbol ExpressionStatement *> children (term expressions) - -declaration :: Assignment (Term Loc) -declaration = everything - where - everything = choice [ - exportStatement, - importAlias', - function, - internalModule, - ambientFunction, - abstractClass, - class', - module', - variableDeclaration, - typeAliasDeclaration, - enumDeclaration, - interfaceDeclaration, - ambientDeclaration - ] - -typeAliasDeclaration :: Assignment (Term Loc) -typeAliasDeclaration = makeTypeAliasDecl <$> symbol Grammar.TypeAliasDeclaration <*> children ((,,) <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> term ty) - where makeTypeAliasDecl loc (identifier, typeParams, body) = makeTerm loc (Declaration.TypeAlias [typeParams] identifier body) - -enumDeclaration :: Assignment (Term Loc) -enumDeclaration = makeTerm <$> symbol Grammar.EnumDeclaration <*> children (TSX.Syntax.EnumDeclaration <$> term identifier <*> (symbol EnumBody *> children (manyTerm (propertyName <|> enumAssignment)))) - -enumAssignment :: Assignment (Term Loc) -enumAssignment = makeTerm <$> symbol Grammar.EnumAssignment <*> children (Statement.Assignment [] <$> term propertyName <*> term expression) - -interfaceDeclaration :: Assignment (Term Loc) -interfaceDeclaration = makeInterfaceDecl <$> symbol Grammar.InterfaceDeclaration <*> children ((,,,) <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> optional (term extendsClause) <*> term objectType) - where makeInterfaceDecl loc (identifier, typeParams, clause, objectType) = makeTerm loc (Declaration.InterfaceDeclaration [typeParams] identifier (toList clause) objectType) - -ambientDeclaration :: Assignment (Term Loc) -ambientDeclaration = makeTerm <$> symbol Grammar.AmbientDeclaration <*> children (TSX.Syntax.AmbientDeclaration <$> term (choice [propertyIdentifier *> ty, declaration, statementBlock])) - -exportStatement :: Assignment (Term Loc) -exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip TSX.Syntax.QualifiedExportFrom <$> exportClause <*> fromClause) - <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TSX.Syntax.QualifiedExport <$> exportClause) - <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TSX.Syntax.DefaultExport <$> contextualize decorator (term (declaration <|> expression <|> identifier <|> importAlias'))) - where - exportClause = symbol Grammar.ExportClause *> children (many exportSymbol) - exportSymbol = symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> (Just <$> rawIdentifier)) - <|> symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> pure Nothing) - makeNameAliasPair from (Just alias) = TSX.Syntax.Alias from alias - makeNameAliasPair from Nothing = TSX.Syntax.Alias from from - rawIdentifier = 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.Term (Sum TSX.Syntax). - fromClause = symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source) - -propertySignature :: Assignment (Term Loc) -propertySignature = makePropertySignature <$> symbol Grammar.PropertySignature <*> children ((,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> (term typeAnnotation' <|> emptyTerm)) - where makePropertySignature loc (modifier, readonly, propertyName, annotation) = makeTerm loc (TSX.Syntax.PropertySignature [readonly, annotation] propertyName modifier) - -propertyName :: Assignment (Term Loc) -propertyName = term (propertyIdentifier <|> string <|> number <|> computedPropertyName) - -computedPropertyName :: Assignment (Term Loc) -computedPropertyName = makeTerm <$> symbol Grammar.ComputedPropertyName <*> children (TSX.Syntax.ComputedPropertyName <$> term expression) - -assignmentPattern :: Assignment (Term Loc) -assignmentPattern = makeTerm <$> symbol AssignmentPattern <*> children (Statement.Assignment [] <$> term shorthandPropertyIdentifier <*> term expression) - -shorthandPropertyIdentifier :: Assignment (Term Loc) -shorthandPropertyIdentifier = makeTerm <$> symbol Grammar.ShorthandPropertyIdentifier <*> (TSX.Syntax.ShorthandPropertyIdentifier <$> source) - -requiredParameter :: Assignment (Term Loc) -requiredParameter = makeRequiredParameter - <$> symbol Grammar.RequiredParameter - <*> children ( (,,,,) - <$> accessibilityModifier' - <*> (term readonly' <|> emptyTerm) - <*> term (identifier <|> destructuringPattern <|> this) - <*> (term typeAnnotation' <|> emptyTerm) - <*> (term expression <|> emptyTerm)) - where - makeRequiredParameter loc (modifier, readonly, identifier, annotation, initializer) = makeTerm loc (TSX.Syntax.RequiredParameter [readonly, annotation] identifier initializer modifier) - -restParameter :: Assignment (Term Loc) -restParameter = makeRestParameter <$> symbol Grammar.RestParameter <*> children ((,) <$> term identifier <*> (term typeAnnotation' <|> emptyTerm)) - where makeRestParameter loc (identifier, annotation) = makeTerm loc (TSX.Syntax.RestParameter [annotation] identifier) - -optionalParameter :: Assignment (Term Loc) -optionalParameter = makeOptionalParam <$> symbol Grammar.OptionalParameter <*> children ((,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> (term identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) - where makeOptionalParam loc (modifier, readonly, subject, annotation, initializer) = makeTerm loc (TSX.Syntax.OptionalParameter [readonly, annotation] (makeTerm loc (Statement.Assignment [] subject initializer)) modifier) - -internalModule :: Assignment (Term Loc) -internalModule = makeTerm <$> symbol Grammar.InternalModule <*> children (TSX.Syntax.InternalModule <$> term (string <|> identifier <|> nestedIdentifier) <*> statements) - -module' :: Assignment (Term Loc) -module' = makeTerm <$> symbol Module <*> children (TSX.Syntax.Module <$> term (string <|> identifier <|> nestedIdentifier) <*> (statements <|> pure [])) - - -statements :: Assignment [Term Loc] -statements = symbol StatementBlock *> children (manyTerm statement) - -arrowFunction :: Assignment (Term Loc) -arrowFunction = makeArrowFun <$> symbol ArrowFunction <*> children ((,,) <$> emptyTerm <*> (((\a b c -> (a, [b], c)) <$> emptyTerm <*> term identifier <*> emptyTerm) <|> callSignatureParts) <*> term (expression <|> statementBlock)) - where makeArrowFun loc (identifier, (typeParams, params, returnTy), body) = makeTerm loc (Declaration.Function [ typeParams, returnTy ] identifier params body) - -comment :: Assignment (Term Loc) -comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) - -ifStatement :: Assignment (Term Loc) -ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term parenthesizedExpression <*> term statement <*> (term statement <|> emptyTerm)) - -whileStatement :: Assignment (Term Loc) -whileStatement = makeTerm <$> symbol WhileStatement <*> children (Statement.While <$> term expression <*> term statement) - -forStatement :: Assignment (Term Loc) -forStatement = makeTerm <$> symbol ForStatement <*> children (Statement.For <$> term (variableDeclaration <|> expressionStatement' <|> emptyStatement) <*> term (expressionStatement' <|> emptyStatement) <*> term (expressions <|> emptyTerm) <*> term statement) - -variableDeclaration :: Assignment (Term Loc) -variableDeclaration = makeTerm <$> (symbol Grammar.VariableDeclaration <|> symbol Grammar.LexicalDeclaration) <*> children (Declaration.VariableDeclaration <$> manyTerm variableDeclarator) - -variableDeclarator :: Assignment (Term Loc) -variableDeclarator = - makeTerm <$> symbol VariableDeclarator <*> children (TSX.Syntax.JavaScriptRequire <$> identifier <*> requireCall) - <|> makeVarDecl <$> symbol VariableDeclarator <*> children ((,,) <$> term (identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) - where - makeVarDecl loc (subject, annotations, value) = makeTerm loc (Statement.Assignment [annotations] subject value) - - requireCall = symbol CallExpression *> children (symbol Identifier *> do - s <- source - guard (s == "require") - symbol Arguments *> children (symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source)) - ) - - -parenthesizedExpression :: Assignment (Term Loc) -parenthesizedExpression = symbol ParenthesizedExpression *> children (term expressions) - -switchStatement :: Assignment (Term Loc) -switchStatement = makeTerm <$> symbol SwitchStatement <*> children (Statement.Match <$> term parenthesizedExpression <*> term switchBody) - where - switchBody = symbol SwitchBody *> children (makeTerm <$> location <*> manyTerm switchCase) - switchCase = makeTerm <$> (symbol SwitchCase <|> symbol SwitchDefault) <*> children (Statement.Pattern <$> (term expressions <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm statement)) - -subscriptExpression :: Assignment (Term Loc) -subscriptExpression = makeTerm <$> symbol SubscriptExpression <*> children (Expression.Subscript <$> term expression <*> (pure <$> term expressions)) - -pair :: Assignment (Term Loc) -pair = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> term propertyName <*> term expression) - -callExpression :: Assignment (Term Loc) -callExpression = makeCall <$> (symbol CallExpression <|> symbol CallExpression') <*> children ((,,,) <$> term (expression <|> super <|> function) <*> (typeArguments <|> pure []) <*> (arguments <|> (pure <$> term templateString)) <*> emptyTerm) - where makeCall loc (subject, typeArgs, args, body) = makeTerm loc (Expression.Call typeArgs subject args body) - typeArguments = symbol Grammar.TypeArguments *> children (some (term ty)) - -arguments :: Assignment [Term Loc] -arguments = symbol Arguments *> children (manyTerm (expression <|> spreadElement)) - -tryStatement :: Assignment (Term Loc) -tryStatement = makeTry <$> symbol TryStatement <*> children ((,,) <$> term statementTerm <*> optional (term catchClause) <*> optional (term finallyClause)) - where - makeTry loc (statementBlock', catch, finally) = makeTerm loc (Statement.Try statementBlock' (catMaybes [catch, finally])) - catchClause = makeTerm <$> symbol CatchClause <*> children (Statement.Catch <$> (identifier <|> emptyTerm) <*> statementTerm) - finallyClause = makeTerm <$> symbol FinallyClause <*> children (Statement.Finally <$> statementTerm) - -binaryExpression :: Assignment (Term Loc) -binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term expression) - [ (inject .) . Expression.Plus <$ symbol AnonPlus - , (inject .) . Expression.Minus <$ symbol AnonMinus - , (inject .) . Expression.Times <$ symbol AnonStar - , (inject .) . Expression.DividedBy <$ symbol AnonSlash - , (inject .) . Expression.Modulo <$ symbol AnonPercent - , (inject .) . Expression.Member <$ symbol AnonIn - , (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand - , (inject .) . Expression.BAnd <$ symbol AnonAmpersand - , (inject .) . Expression.Or <$ symbol AnonPipePipe - , (inject .) . Expression.BOr <$ symbol AnonPipe - , (inject .) . Expression.BXOr <$ symbol AnonCaret - , (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof - , (inject .) . Expression.Equal <$ symbol AnonEqualEqual - , (inject .) . Expression.StrictEqual <$ symbol AnonEqualEqualEqual - , (inject .) . invert Expression.Equal <$ symbol AnonBangEqual - , (inject .) . invert Expression.StrictEqual <$ symbol AnonBangEqualEqual - , (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle - , (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle - , (inject .) . Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngle - , (inject .) . Expression.LessThan <$ symbol AnonLAngle - , (inject .) . Expression.GreaterThan <$ symbol AnonRAngle - , (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual - , (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual - ]) - where invert cons a b = Expression.Not (makeTerm1 (cons a b)) - - --- Helpers - --- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] -manyTerm term = many (contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)) - -term :: Assignment (Term Loc) -> Assignment (Term Loc) -term term = contextualize comment (postContextualize comment term) - -emptyStatement :: Assignment (Term Loc) -emptyStatement = makeTerm <$> symbol EmptyStatement <*> (Syntax.Empty <$ rawSource <|> pure Syntax.Empty) - --- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment (Term Loc) - -> Assignment (Term Loc) - -> [Assignment (Term Loc -> Term Loc -> Sum TSX.Syntax (Term Loc))] - -> Assignment (Sum TSX.Syntax (Term Loc)) -infixTerm = infixContext comment diff --git a/src/Language/TSX/Syntax.hs b/src/Language/TSX/Syntax.hs deleted file mode 100644 index caef2e7388..0000000000 --- a/src/Language/TSX/Syntax.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Language.TSX.Syntax ( module X ) where - -import Language.TypeScript.Syntax.Import as X -import Language.TypeScript.Syntax.JavaScript as X -import Language.TSX.Syntax.JSX as X -import Language.TypeScript.Syntax.TypeScript as X -import Language.TypeScript.Syntax.Types as X diff --git a/src/Language/TSX/Syntax/JSX.hs b/src/Language/TSX/Syntax/JSX.hs deleted file mode 100644 index 23ac6970ee..0000000000 --- a/src/Language/TSX/Syntax/JSX.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -module Language.TSX.Syntax.JSX (module Language.TSX.Syntax.JSX) where - -import Data.Abstract.Evaluatable -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import qualified Data.Text as T -import GHC.Generics (Generic1) - - -data JsxElement a = JsxElement { jsxOpeningElement :: !a, jsxElements :: ![a], jsxClosingElement :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JsxElement where liftEq = genericLiftEq -instance Ord1 JsxElement where liftCompare = genericLiftCompare -instance Show1 JsxElement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JsxElement - -newtype JsxText a = JsxText { contents :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JsxText where liftEq = genericLiftEq -instance Ord1 JsxText where liftCompare = genericLiftCompare -instance Show1 JsxText where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JsxText - -newtype JsxExpression a = JsxExpression { jsxExpression :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JsxExpression where liftEq = genericLiftEq -instance Ord1 JsxExpression where liftCompare = genericLiftCompare -instance Show1 JsxExpression where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JsxExpression - -data JsxOpeningElement a = JsxOpeningElement { jsxOpeningElementIdentifier :: !a, jsxOpeningElementTypeArguments :: a, jsxAttributes :: ![a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JsxOpeningElement where liftEq = genericLiftEq -instance Ord1 JsxOpeningElement where liftCompare = genericLiftCompare -instance Show1 JsxOpeningElement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JsxOpeningElement - -newtype JsxClosingElement a = JsxClosingElement { jsxClosingElementIdentifier :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JsxClosingElement where liftEq = genericLiftEq -instance Ord1 JsxClosingElement where liftCompare = genericLiftCompare -instance Show1 JsxClosingElement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JsxClosingElement - -data JsxSelfClosingElement a = JsxSelfClosingElement { jsxSelfClosingElementIdentifier :: !a, jsxSelfClosingElementAttributes :: ![a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JsxSelfClosingElement where liftEq = genericLiftEq -instance Ord1 JsxSelfClosingElement where liftCompare = genericLiftCompare -instance Show1 JsxSelfClosingElement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JsxSelfClosingElement - -data JsxAttribute a = JsxAttribute { jsxAttributeTarget :: !a, jsxAttributeValue :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JsxAttribute where liftEq = genericLiftEq -instance Ord1 JsxAttribute where liftCompare = genericLiftCompare -instance Show1 JsxAttribute where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JsxAttribute - -newtype JsxFragment a = JsxFragment { terms :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JsxFragment where liftEq = genericLiftEq -instance Ord1 JsxFragment where liftCompare = genericLiftCompare -instance Show1 JsxFragment where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JsxFragment - -data JsxNamespaceName a = JsxNamespaceName { left :: a, right :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JsxNamespaceName where liftEq = genericLiftEq -instance Ord1 JsxNamespaceName where liftCompare = genericLiftCompare -instance Show1 JsxNamespaceName where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JsxNamespaceName diff --git a/src/Language/TSX/Term.hs b/src/Language/TSX/Term.hs deleted file mode 100644 index d4a35e671d..0000000000 --- a/src/Language/TSX/Term.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, RecordWildCards, TypeFamilies #-} -module Language.TSX.Term -( Syntax -, Term(..) -) where - -import Control.Lens.Lens -import Data.Abstract.Declarations -import Data.Abstract.FreeVariables -import Data.Bitraversable -import Data.Coerce -import Data.Foldable (fold) -import Data.Functor.Foldable (Base, Recursive(..)) -import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) -import qualified Data.Sum as Sum -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term -import Data.Traversable -import qualified Language.TSX.Syntax as TSX.Syntax -import Source.Loc -import Source.Span - -type Syntax = - [ Comment.Comment - , Comment.HashBang - , Declaration.Class - , Declaration.Function - , Declaration.Method - , Declaration.MethodSignature - , Declaration.InterfaceDeclaration - , Declaration.PublicFieldDefinition - , Declaration.VariableDeclaration - , Declaration.TypeAlias - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.UnsignedRShift - , Expression.Complement - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.Call - , Expression.Cast - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Enumeration - , Expression.MemberAccess - , Expression.NonNullExpression - , Expression.ScopeResolution - , Expression.SequenceExpression - , Expression.Subscript - , Expression.Member - , Expression.Delete - , Expression.Void - , Expression.Typeof - , Expression.InstanceOf - , Expression.New - , Expression.Await - , Expression.This - , Literal.Array - , Literal.Boolean - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.KeyValue - , Literal.Null - , Literal.String - , Literal.TextElement - , Literal.Regex - , Statement.Assignment - , Statement.AugmentedAssignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.DoWhile - , Statement.Else - , Statement.Finally - , Statement.For - , Statement.ForEach - , Statement.If - , Statement.Match - , Statement.Pattern - , Statement.Retry - , Statement.Return - , Statement.ScopeEntry - , Statement.ScopeExit - , Statement.Statements - , Statement.Throw - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.AccessibilityModifier - , Syntax.Empty - , Syntax.Error - , Syntax.Identifier - , Syntax.Context - , Type.Readonly - , Type.TypeParameters - , TSX.Syntax.TypeParameter - , TSX.Syntax.Constraint - , TSX.Syntax.ParenthesizedType - , TSX.Syntax.DefaultType - , TSX.Syntax.PredefinedType - , TSX.Syntax.TypeIdentifier - , TSX.Syntax.NestedIdentifier - , TSX.Syntax.NestedTypeIdentifier - , TSX.Syntax.GenericType - , TSX.Syntax.TypeArguments - , TSX.Syntax.TypePredicate - , TSX.Syntax.CallSignature - , TSX.Syntax.ConstructSignature - , TSX.Syntax.ArrayType - , TSX.Syntax.LookupType - , TSX.Syntax.FlowMaybeType - , TSX.Syntax.TypeQuery - , TSX.Syntax.IndexTypeQuery - , TSX.Syntax.ThisType - , TSX.Syntax.ExistentialType - , TSX.Syntax.AbstractMethodSignature - , TSX.Syntax.IndexSignature - , TSX.Syntax.ObjectType - , TSX.Syntax.LiteralType - , TSX.Syntax.Union - , TSX.Syntax.Intersection - , TSX.Syntax.Module - , TSX.Syntax.InternalModule - , TSX.Syntax.FunctionType - , TSX.Syntax.Tuple - , TSX.Syntax.Constructor - , TSX.Syntax.TypeAssertion - , TSX.Syntax.ImportAlias - , TSX.Syntax.Debugger - , TSX.Syntax.ShorthandPropertyIdentifier - , TSX.Syntax.Super - , TSX.Syntax.Undefined - , TSX.Syntax.ClassHeritage - , TSX.Syntax.AbstractClass - , TSX.Syntax.ImplementsClause - , TSX.Syntax.JsxElement - , TSX.Syntax.JsxSelfClosingElement - , TSX.Syntax.JsxOpeningElement - , TSX.Syntax.JsxText - , TSX.Syntax.JsxClosingElement - , TSX.Syntax.JsxExpression - , TSX.Syntax.JsxAttribute - , TSX.Syntax.JsxFragment - , TSX.Syntax.JsxNamespaceName - , TSX.Syntax.OptionalParameter - , TSX.Syntax.RequiredParameter - , TSX.Syntax.RestParameter - , TSX.Syntax.PropertySignature - , TSX.Syntax.AmbientDeclaration - , TSX.Syntax.EnumDeclaration - , TSX.Syntax.ExtendsClause - , TSX.Syntax.AmbientFunction - , TSX.Syntax.ImportRequireClause - , TSX.Syntax.ImportClause - , TSX.Syntax.LabeledStatement - , TSX.Syntax.Annotation - , TSX.Syntax.With - , TSX.Syntax.ForOf - , TSX.Syntax.Update - , TSX.Syntax.ComputedPropertyName - , TSX.Syntax.Decorator - , TSX.Syntax.Import - , TSX.Syntax.QualifiedAliasedImport - , TSX.Syntax.SideEffectImport - , TSX.Syntax.DefaultExport - , TSX.Syntax.QualifiedExport - , TSX.Syntax.QualifiedExportFrom - , TSX.Syntax.JavaScriptRequire - , [] - , Statement.StatementBlock - , TSX.Syntax.MetaProperty - , TSX.Syntax.AnnotatedExpression - ] - - -newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } - deriving (Eq, Declarations, FreeVariables, Ord, Show) - -instance Term.IsTerm Term where - type Syntax Term = Sum.Sum Syntax - toTermF = coerce - fromTermF = coerce - -instance Foldable Term where - foldMap = foldMapDefault - -instance Functor Term where - fmap = fmapDefault - -instance Traversable Term where - traverse f = go where go = fmap Term . bitraverse f go . getTerm - -instance VertexDeclaration Term where - toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax - -instance Syntax.HasErrors Term where - getErrors = cata $ \ (Term.In Loc{..} syntax) -> - maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) - - -type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann - -instance Recursive (Term ann) where - project = getTerm - -instance HasSpan ann => HasSpan (Term ann) where - span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) - {-# INLINE span_ #-} diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs deleted file mode 100644 index 6bfcbceb00..0000000000 --- a/src/Language/TypeScript/Assignment.hs +++ /dev/null @@ -1,761 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Language.TypeScript.Assignment -( assignment -, TypeScript.Syntax -, Grammar -, TypeScript.Term(..) -) where - -import Analysis.Name (name) -import Assigning.Assignment hiding (Assignment, Error) -import qualified Assigning.Assignment as Assignment -import Control.Monad -import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..)) -import Data.Foldable -import Data.Function -import Data.List.NonEmpty (nonEmpty, some1) -import Data.Maybe -import Data.Sum -import Data.Syntax - ( contextualize - , emptyTerm - , handleError - , infixContext - , makeTerm - , makeTerm' - , makeTerm'' - , makeTerm1 - , parseError - , postContextualize - ) -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import Language.TypeScript.Grammar as Grammar -import qualified Language.TypeScript.Resolution as TypeScript.Resolution -import qualified Language.TypeScript.Syntax as TypeScript.Syntax -import Language.TypeScript.Term as TypeScript - -type Assignment = Assignment.Assignment Grammar - --- | Assignment from AST in TypeScript’s grammar onto a program in TypeScript’s syntax. -assignment :: Assignment (Term Loc) -assignment = handleError $ makeTerm <$> symbol Program <*> children (Statement.Statements <$> manyTerm statement) <|> parseError - -expression :: Assignment (Term Loc) -expression = handleError everything - where - everything = choice [ - typeAssertion, - asExpression, - nonNullExpression', - importAlias', - internalModule, - super, - object, - array, - class', - function, - arrowFunction, - assignmentExpression, - augmentedAssignmentExpression, - awaitExpression, - unaryExpression, - binaryExpression, - ternaryExpression, - updateExpression, - callExpression, - memberExpression, - newExpression, - parenthesizedExpression, - subscriptExpression, - yieldExpression, - this, - number, - string, - templateString, - regex, - true, - false, - null', - undefined', - identifier - ] - -undefined' :: Assignment (Term Loc) -undefined' = makeTerm <$> symbol Grammar.Undefined <*> (TypeScript.Syntax.Undefined <$ rawSource) - -assignmentExpression :: Assignment (Term Loc) -assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) <*> expression) - -augmentedAssignmentExpression :: Assignment (Term Loc) -augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) (term expression) [ - assign Expression.Plus <$ symbol AnonPlusEqual - , assign Expression.Minus <$ symbol AnonMinusEqual - , assign Expression.Times <$ symbol AnonStarEqual - , assign Expression.DividedBy <$ symbol AnonSlashEqual - , assign Expression.Modulo <$ symbol AnonPercentEqual - , assign Expression.BXOr <$ symbol AnonCaretEqual - , assign Expression.BAnd <$ symbol AnonAmpersandEqual - , assign Expression.RShift <$ symbol AnonRAngleRAngleEqual - , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual - , assign Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngleEqual - , assign Expression.LShift <$ symbol AnonLAngleLAngleEqual - , assign Expression.BOr <$ symbol AnonPipeEqual ]) - where assign :: (f :< TypeScript.Syntax) => (Term Loc -> Term Loc -> f (Term Loc)) -> Term Loc -> Term Loc -> Sum TypeScript.Syntax (Term Loc) - assign c l r = inject (Statement.AugmentedAssignment (makeTerm1 (c l r))) - - -awaitExpression :: Assignment (Term Loc) -awaitExpression = makeTerm <$> symbol Grammar.AwaitExpression <*> children (Expression.Await <$> term expression) - -unaryExpression :: Assignment (Term Loc) -unaryExpression = symbol Grammar.UnaryExpression >>= \ loc -> - makeTerm loc . Expression.Not <$> children (symbol AnonBang *> term expression) - <|> makeTerm loc . Expression.Complement <$> children (symbol AnonTilde *> term expression) - <|> makeTerm loc . Expression.Negate <$> children ((symbol AnonMinus <|> symbol AnonPlus) *> term expression) - <|> makeTerm loc . Expression.Typeof <$> children (symbol AnonTypeof *> term expression) - <|> makeTerm loc . Expression.Void <$> children (symbol AnonVoid *> term expression) - <|> makeTerm loc . Expression.Delete <$> children (symbol AnonDelete *> term expression) - -ternaryExpression :: Assignment (Term Loc) -ternaryExpression = makeTerm <$> symbol Grammar.TernaryExpression <*> children (Statement.If <$> term expression <*> term expression <*> term expression) - -memberExpression :: Assignment (Term Loc) -memberExpression = makeTerm <$> (symbol Grammar.MemberExpression <|> symbol Grammar.MemberExpression') <*> children (Expression.MemberAccess <$> term expression <*> propertyIdentifier) - -newExpression :: Assignment (Term Loc) -newExpression = makeTerm <$> symbol Grammar.NewExpression <*> children (Expression.New <$> term constructableExpression <*> (typeArguments' <|> emptyTerm) <*> (arguments <|> pure [])) - -constructableExpression :: Assignment (Term Loc) -constructableExpression = choice [ - this - , identifier - , number - , string - , templateString - , regex - , true - , false - , null' - , undefined' - , object - , array - , function - , arrowFunction - , class' - , parenthesizedExpression - , subscriptExpression - , memberExpression - , metaProperty - , newExpression - ] - -metaProperty :: Assignment (Term Loc) -metaProperty = makeTerm <$> symbol Grammar.MetaProperty <*> (TypeScript.Syntax.MetaProperty <$ rawSource) - -updateExpression :: Assignment (Term Loc) -updateExpression = makeTerm <$> symbol Grammar.UpdateExpression <*> children (TypeScript.Syntax.Update <$> term expression) - -yieldExpression :: Assignment (Term Loc) -yieldExpression = makeTerm <$> symbol Grammar.YieldExpression <*> children (Statement.Yield <$> term (expression <|> emptyTerm)) - -this :: Assignment (Term Loc) -this = makeTerm <$> symbol Grammar.This <*> (Expression.This <$ rawSource) - -regex :: Assignment (Term Loc) -regex = makeTerm <$> symbol Grammar.Regex <*> (Literal.Regex <$> source) - -null' :: Assignment (Term Loc) -null' = makeTerm <$> symbol Null <*> (Literal.Null <$ rawSource) - -abstractClass :: Assignment (Term Loc) -abstractClass = makeTerm <$> symbol Grammar.AbstractClassDeclaration <*> children (TypeScript.Syntax.AbstractClass <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> (classHeritage' <|> pure []) <*> classBodyStatements) - -abstractMethodSignature :: Assignment (Term Loc) -abstractMethodSignature = makeSignature <$> symbol Grammar.AbstractMethodSignature <*> children ((,,) <$> accessibilityModifier' <*> term propertyName <*> callSignatureParts) - where makeSignature loc (modifier, propertyName, (typeParams, params, annotation)) = makeTerm loc (TypeScript.Syntax.AbstractMethodSignature [typeParams, annotation] propertyName params modifier) - -classHeritage' :: Assignment [Term Loc] -classHeritage' = symbol Grammar.ClassHeritage *> children ((mappend `on` toList) <$> optional (term extendsClause) <*> optional (term implementsClause')) - -extendsClause :: Assignment (Term Loc) -extendsClause = makeTerm <$> symbol Grammar.ExtendsClause <*> children (TypeScript.Syntax.ExtendsClause <$> manyTerm (typeReference <|> expression)) - -typeReference :: Assignment (Term Loc) -typeReference = typeIdentifier <|> nestedTypeIdentifier <|> genericType - -implementsClause' :: Assignment (Term Loc) -implementsClause' = makeTerm <$> symbol Grammar.ImplementsClause <*> children (TypeScript.Syntax.ImplementsClause <$> manyTerm ty) - -super :: Assignment (Term Loc) -super = makeTerm <$> symbol Grammar.Super <*> (TypeScript.Syntax.Super <$ rawSource) - -typeAssertion :: Assignment (Term Loc) -typeAssertion = makeTerm <$> symbol Grammar.TypeAssertion <*> children (TypeScript.Syntax.TypeAssertion <$> term typeArguments' <*> term expression) - -asExpression :: Assignment (Term Loc) -asExpression = makeTerm <$> symbol AsExpression <*> children (Expression.Cast <$> term expression <*> term (ty <|> templateString)) - -templateString :: Assignment (Term Loc) -templateString = makeTerm <$> symbol TemplateString <*> children (Literal.String <$> manyTerm templateSubstitution) - -templateSubstitution :: Assignment (Term Loc) -templateSubstitution = symbol TemplateSubstitution *> children (term expressions) - -nonNullExpression' :: Assignment (Term Loc) -nonNullExpression' = makeTerm <$> symbol Grammar.NonNullExpression <*> children (Expression.NonNullExpression <$> term expression) - -importAlias' :: Assignment (Term Loc) -importAlias' = makeTerm <$> symbol Grammar.ImportAlias <*> children (TypeScript.Syntax.ImportAlias <$> term identifier <*> term (identifier <|> nestedIdentifier)) - -number :: Assignment (Term Loc) -number = makeTerm <$> symbol Grammar.Number <*> (Literal.Float <$> source) - -string :: Assignment (Term Loc) -string = makeTerm <$> symbol Grammar.String <*> (Literal.TextElement <$> source) - -true :: Assignment (Term Loc) -true = makeTerm <$> symbol Grammar.True <*> (Literal.true <$ rawSource) - -false :: Assignment (Term Loc) -false = makeTerm <$> symbol Grammar.False <*> (Literal.false <$ rawSource) - -identifier :: Assignment (Term Loc) -identifier = makeTerm <$> symbol Identifier <*> (Syntax.Identifier . name <$> source) - -class' :: Assignment (Term Loc) -class' = makeClass <$> (symbol Class <|> symbol ClassDeclaration) <*> children ((,,,,) <$> manyTerm decorator - <*> (term typeIdentifier <|> emptyTerm) - <*> (symbol TypeParameters *> children (manyTerm typeParameter') <|> pure []) - <*> (classHeritage' <|> pure []) - <*> classBodyStatements) - where makeClass loc (decorators, expression, typeParams, classHeritage, statements) = makeTerm loc (Declaration.Class (decorators <> typeParams) expression classHeritage statements) - -object :: Assignment (Term Loc) -object = makeTerm <$> (symbol Object <|> symbol ObjectPattern) <*> children (Literal.Hash <$> manyTerm (pair <|> spreadElement <|> methodDefinition <|> assignmentPattern <|> shorthandPropertyIdentifier)) - -array :: Assignment (Term Loc) -array = makeTerm <$> (symbol Array <|> symbol ArrayPattern) <*> children (Literal.Array <$> manyTerm (expression <|> spreadElement)) - -propertyIdentifier :: Assignment (Term Loc) -propertyIdentifier = makeTerm <$> symbol PropertyIdentifier <*> (Syntax.Identifier . name <$> source) - -sequenceExpression :: Assignment (Term Loc) -sequenceExpression = makeTerm <$> symbol Grammar.SequenceExpression <*> children (Expression.SequenceExpression <$> term expression <*> term expressions) - -expressions :: Assignment (Term Loc) -expressions = annotatedExpression <|> expression <|> sequenceExpression - -annotatedExpression :: Assignment (Term Loc) -annotatedExpression = mkAnnotated <$> location <*> expression <*> typeAnnotation' - where mkAnnotated loc expr ann = makeTerm loc (TypeScript.Syntax.AnnotatedExpression expr ann) - -parameter :: Assignment (Term Loc) -parameter = requiredParameter - <|> restParameter - <|> optionalParameter - -accessibilityModifier' :: Assignment ScopeGraph.AccessControl -accessibilityModifier' = (symbol AccessibilityModifier >> children (public <|> protected <|> private)) <|> default' - where public = symbol AnonPublic >> pure ScopeGraph.Public - protected = symbol AnonProtected >> pure ScopeGraph.Protected - private = symbol AnonPrivate >> pure ScopeGraph.Private - default' = pure ScopeGraph.Public - - -destructuringPattern :: Assignment (Term Loc) -destructuringPattern = object <|> array - -spreadElement :: Assignment (Term Loc) -spreadElement = symbol SpreadElement *> children (term expression) - -readonly' :: Assignment (Term Loc) -readonly' = makeTerm <$> symbol Readonly <*> (Type.Readonly <$ rawSource) - -methodDefinition :: Assignment (Term Loc) -methodDefinition = makeMethod <$> - symbol MethodDefinition - <*> children ((,,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> emptyTerm <*> term propertyName <*> callSignatureParts <*> term statementBlock) - where - makeMethod loc (modifier, readonly, receiver, propertyName', (typeParameters', params, ty'), statements) = makeTerm loc (Declaration.Method [readonly, typeParameters', ty'] receiver propertyName' params statements modifier) - -callSignatureParts :: Assignment (Term Loc, [Term Loc], Term Loc) -callSignatureParts = contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> callSignature' <*> many comment) - where - callSignature' = (,,) <$> (term typeParameters <|> emptyTerm) <*> formalParameters <*> (term typeAnnotation' <|> emptyTerm) - contextualize' (cs, (typeParams, formalParams, annotation)) = case nonEmpty cs of - Just cs -> (makeTerm1 (Syntax.Context cs typeParams), formalParams, annotation) - Nothing -> (typeParams, formalParams, annotation) - postContextualize' (typeParams, formalParams, annotation) cs = case nonEmpty cs of - Just cs -> (typeParams, formalParams, makeTerm1 (Syntax.Context cs annotation)) - Nothing -> (typeParams, formalParams, annotation) - -callSignature :: Assignment (Term Loc) -callSignature = makeTerm <$> symbol Grammar.CallSignature <*> children (TypeScript.Syntax.CallSignature <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional (term typeAnnotation'))) - -constructSignature :: Assignment (Term Loc) -constructSignature = makeTerm <$> symbol Grammar.ConstructSignature <*> children (TypeScript.Syntax.ConstructSignature <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> (fromMaybe <$> emptyTerm <*> optional (term typeAnnotation'))) - -indexSignature :: Assignment (Term Loc) -indexSignature = makeTerm <$> symbol Grammar.IndexSignature <*> children (TypeScript.Syntax.IndexSignature <$> term identifier <*> predefinedTy <*> term typeAnnotation') - -methodSignature :: Assignment (Term Loc) -methodSignature = makeMethodSignature <$> symbol Grammar.MethodSignature <*> children ((,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> callSignatureParts) - where makeMethodSignature loc (accessControl, readonly, propertyName, (typeParams, params, annotation)) = makeTerm loc (Declaration.MethodSignature [readonly, typeParams, annotation] propertyName params accessControl) - -formalParameters :: Assignment [Term Loc] -formalParameters = symbol FormalParameters *> children (contextualize' <$> Assignment.manyThrough comment (postContextualize' <$> (concat <$> many ((\as b -> as <> [b]) <$> manyTerm decorator <*> term parameter)) <*> many comment)) - where - contextualize' (cs, formalParams) = case nonEmpty cs of - Just cs -> toList cs <> formalParams - Nothing -> formalParams - postContextualize' formalParams cs = case nonEmpty cs of - Just cs -> formalParams <> toList cs - Nothing -> formalParams - - -decorator :: Assignment (Term Loc) -decorator = makeTerm <$> symbol Grammar.Decorator <*> children (TypeScript.Syntax.Decorator <$> term (identifier <|> memberExpression <|> callExpression)) - -typeParameters :: Assignment (Term Loc) -typeParameters = makeTerm <$> symbol TypeParameters <*> children (Type.TypeParameters <$> manyTerm typeParameter') - -typeAnnotation' :: Assignment (Term Loc) -typeAnnotation' = makeTerm <$> symbol TypeAnnotation <*> children (TypeScript.Syntax.Annotation <$> term ty) - -typeParameter' :: Assignment (Term Loc) -typeParameter' = makeTerm <$> symbol Grammar.TypeParameter <*> children (TypeScript.Syntax.TypeParameter <$> term typeIdentifier <*> term (constraint <|> emptyTerm) <*> term (defaultType <|> emptyTerm)) - -defaultType :: Assignment (Term Loc) -defaultType = makeTerm <$> symbol Grammar.DefaultType <*> children (TypeScript.Syntax.DefaultType <$> term ty) - -constraint :: Assignment (Term Loc) -constraint = makeTerm <$> symbol Grammar.Constraint <*> children (TypeScript.Syntax.Constraint <$> term ty) - -function :: Assignment (Term Loc) -function = makeFunction <$> (symbol Grammar.Function <|> symbol Grammar.FunctionDeclaration <|> symbol Grammar.GeneratorFunction <|> symbol Grammar.GeneratorFunctionDeclaration) <*> children ((,,) <$> term (identifier <|> emptyTerm) <*> callSignatureParts <*> term statementBlock) - where makeFunction loc (id, (typeParams, params, annotation), statements) = makeTerm loc (Declaration.Function [typeParams, annotation] id params statements) - --- TODO: FunctionSignatures can, but don't have to be ambient functions. -ambientFunction :: Assignment (Term Loc) -ambientFunction = makeAmbientFunction <$> symbol Grammar.FunctionSignature <*> children ((,) <$> term identifier <*> callSignatureParts) - where makeAmbientFunction loc (id, (typeParams, params, annotation)) = makeTerm loc (TypeScript.Syntax.AmbientFunction [typeParams, annotation] id params) - -ty :: Assignment (Term Loc) -ty = primaryType <|> unionType <|> intersectionType <|> functionTy <|> constructorTy - -primaryType :: Assignment (Term Loc) -primaryType = arrayTy - <|> existentialType - <|> flowMaybeTy - <|> genericType - <|> indexTypeQuery - <|> literalType - <|> lookupType - <|> nestedTypeIdentifier - <|> objectType - <|> parenthesizedTy - <|> predefinedTy - <|> this - <|> tupleType - <|> typeIdentifier - <|> typePredicate - <|> typeQuery - -parenthesizedTy :: Assignment (Term Loc) -parenthesizedTy = makeTerm <$> symbol Grammar.ParenthesizedType <*> children (TypeScript.Syntax.ParenthesizedType <$> term ty) - -predefinedTy :: Assignment (Term Loc) -predefinedTy = makeTerm <$> symbol Grammar.PredefinedType <*> (TypeScript.Syntax.PredefinedType <$> source) - -typeIdentifier :: Assignment (Term Loc) -typeIdentifier = makeTerm <$> symbol Grammar.TypeIdentifier <*> (TypeScript.Syntax.TypeIdentifier <$> source) - -nestedIdentifier :: Assignment (Term Loc) -nestedIdentifier = makeTerm <$> symbol Grammar.NestedIdentifier <*> children (TypeScript.Syntax.NestedIdentifier <$> term (identifier <|> nestedIdentifier) <*> term identifier) - -nestedTypeIdentifier :: Assignment (Term Loc) -nestedTypeIdentifier = makeTerm <$> symbol Grammar.NestedTypeIdentifier <*> children (TypeScript.Syntax.NestedTypeIdentifier <$> term (identifier <|> nestedIdentifier) <*> term typeIdentifier) - -genericType :: Assignment (Term Loc) -genericType = makeTerm <$> symbol Grammar.GenericType <*> children (TypeScript.Syntax.GenericType <$> term (typeIdentifier <|> nestedTypeIdentifier) <*> term typeArguments') - -typeArguments' :: Assignment (Term Loc) -typeArguments' = makeTerm <$> symbol Grammar.TypeArguments <*> children (TypeScript.Syntax.TypeArguments <$> some (term ty)) - -typePredicate :: Assignment (Term Loc) -typePredicate = makeTerm <$> symbol Grammar.TypePredicate <*> children (TypeScript.Syntax.TypePredicate <$> term identifier <*> term ty) - -objectType :: Assignment (Term Loc) -objectType = makeTerm <$> symbol Grammar.ObjectType <*> children (TypeScript.Syntax.ObjectType <$> manyTerm (exportStatement <|> propertySignature <|> callSignature <|> constructSignature <|> indexSignature <|> methodSignature)) - -arrayTy :: Assignment (Term Loc) -arrayTy = makeTerm <$> symbol Grammar.ArrayType <*> children (TypeScript.Syntax.ArrayType <$> term ty) - -lookupType :: Assignment (Term Loc) -lookupType = makeTerm <$> symbol Grammar.LookupType <*> children (TypeScript.Syntax.LookupType <$> term (typeIdentifier <|> nestedTypeIdentifier) <*> term ty) - -flowMaybeTy :: Assignment (Term Loc) -flowMaybeTy = makeTerm <$> symbol Grammar.FlowMaybeType <*> children (TypeScript.Syntax.FlowMaybeType <$> term primaryType) - -typeQuery :: Assignment (Term Loc) -typeQuery = makeTerm <$> symbol Grammar.TypeQuery <*> children (TypeScript.Syntax.TypeQuery <$> term (identifier <|> nestedIdentifier)) - -indexTypeQuery :: Assignment (Term Loc) -indexTypeQuery = makeTerm <$> symbol Grammar.IndexTypeQuery <*> children (TypeScript.Syntax.IndexTypeQuery <$> term (typeIdentifier <|> nestedTypeIdentifier)) - -existentialType :: Assignment (Term Loc) -existentialType = makeTerm <$> symbol Grammar.ExistentialType <*> (TypeScript.Syntax.ExistentialType <$> source) - -literalType :: Assignment (Term Loc) -literalType = makeTerm <$> symbol Grammar.LiteralType <*> children (TypeScript.Syntax.LiteralType <$> term (number <|> string <|> true <|> false)) - -unionType :: Assignment (Term Loc) -unionType = makeTerm <$> symbol UnionType <*> children (TypeScript.Syntax.Union <$> (term ty <|> emptyTerm) <*> term ty) - -intersectionType :: Assignment (Term Loc) -intersectionType = makeTerm <$> symbol IntersectionType <*> children (TypeScript.Syntax.Intersection <$> term ty <*> term ty) - -functionTy :: Assignment (Term Loc) -functionTy = makeTerm <$> symbol Grammar.FunctionType <*> children (TypeScript.Syntax.FunctionType <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty) - -tupleType :: Assignment (Term Loc) -tupleType = makeTerm <$> symbol TupleType <*> children (TypeScript.Syntax.Tuple <$> manyTerm ty) - -constructorTy :: Assignment (Term Loc) -constructorTy = makeTerm <$> symbol ConstructorType <*> children (TypeScript.Syntax.Constructor <$> (fromMaybe <$> emptyTerm <*> optional (term typeParameters)) <*> formalParameters <*> term ty) - -statementTerm :: Assignment (Term Loc) -statementTerm = makeTerm <$> symbol StatementBlock <*> children (Statement.Statements <$> manyTerm statement) - -statementBlock :: Assignment (Term Loc) -statementBlock = makeTerm <$> symbol StatementBlock <*> children (Statement.StatementBlock <$> manyTerm statement) - -classBodyStatements :: Assignment (Term Loc) -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)) - where - contextualize' (cs, formalParams) = case nonEmpty cs of - Just cs -> toList cs <> formalParams - Nothing -> formalParams - postContextualize' formalParams cs = case nonEmpty cs of - Just cs -> formalParams <> toList cs - Nothing -> formalParams - -publicFieldDefinition :: Assignment (Term Loc) -publicFieldDefinition = makeField <$> symbol Grammar.PublicFieldDefinition <*> children ((,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) - where makeField loc (accessControl, readonly, propertyName, annotation, expression) = makeTerm loc (Declaration.PublicFieldDefinition [readonly, annotation] propertyName expression accessControl) - - -statement :: Assignment (Term Loc) -statement = handleError everything - where - everything = choice [ - exportStatement - , importStatement - , debuggerStatement - , expressionStatement' - , declaration - , statementTerm - , ifStatement - , switchStatement - , forStatement - , forInStatement - , whileStatement - , doStatement - , tryStatement - , withStatement - , breakStatement - , continueStatement - , returnStatement - , throwStatement - , hashBang - , emptyStatement - , labeledStatement ] - -forInStatement :: Assignment (Term Loc) -forInStatement = makeTerm <$> symbol ForInStatement <*> children (Statement.ForEach <$> term expression <*> term expression <*> term statement) - -doStatement :: Assignment (Term Loc) -doStatement = makeTerm <$> symbol DoStatement <*> children (flip Statement.DoWhile <$> term statement <*> term parenthesizedExpression) - -continueStatement :: Assignment (Term Loc) -continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (statementIdentifier <|> term emptyTerm)) - -breakStatement :: Assignment (Term Loc) -breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (statementIdentifier <|> term emptyTerm)) - -withStatement :: Assignment (Term Loc) -withStatement = makeTerm <$> symbol WithStatement <*> children (TypeScript.Syntax.With <$> term parenthesizedExpression <*> term statement) - -returnStatement :: Assignment (Term Loc) -returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expressions <|> term emptyTerm)) - -throwStatement :: Assignment (Term Loc) -throwStatement = makeTerm <$> symbol Grammar.ThrowStatement <*> children (Statement.Throw <$> term expressions) - -hashBang :: Assignment (Term Loc) -hashBang = makeTerm <$> symbol HashBangLine <*> (Comment.HashBang <$> source) - -labeledStatement :: Assignment (Term Loc) -labeledStatement = makeTerm <$> symbol Grammar.LabeledStatement <*> children (TypeScript.Syntax.LabeledStatement <$> statementIdentifier <*> term statement) - -statementIdentifier :: Assignment (Term Loc) -statementIdentifier = makeTerm <$> symbol StatementIdentifier <*> (Syntax.Identifier . name <$> source) - -importStatement :: Assignment (Term Loc) -importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> children ((,) <$> importClause <*> fromClause) - <|> makeTerm' <$> symbol Grammar.ImportStatement <*> children (requireImport <|> sideEffectImport) - where - -- `import foo = require("./foo")` - requireImport = inject <$> (symbol Grammar.ImportRequireClause *> children (TypeScript.Syntax.QualifiedAliasedImport <$> term identifier <*> fromClause)) - -- `import "./foo"` - sideEffectImport = inject <$> (TypeScript.Syntax.SideEffectImport <$> fromClause) - -- `import { bar } from "./foo"` - namedImport = (,) Nothing <$> (symbol Grammar.NamedImports *> children (many importSymbol)) - -- `import defaultMember from "./foo"` - defaultImport = (,) Nothing <$> (pure <$> (makeNameAliasPair <$> rawIdentifier <*> pure Nothing)) - -- `import * as name from "./foo"` - namespaceImport = symbol Grammar.NamespaceImport *> children ((,) . Just <$> term identifier <*> pure []) - - -- Combinations of the above. - importClause = symbol Grammar.ImportClause *> - children ( - (pure <$> namedImport) - <|> (pure <$> namespaceImport) - <|> ((\a b -> [a, b]) <$> defaultImport <*> (namedImport <|> namespaceImport)) - <|> (pure <$> defaultImport)) - - makeImportTerm1 loc from (Just alias, _) = makeTerm loc (TypeScript.Syntax.QualifiedAliasedImport alias from) - makeImportTerm1 loc from (Nothing, symbols) = makeTerm loc (TypeScript.Syntax.Import (uncurry TypeScript.Syntax.Alias <$> symbols) from) - 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 *> (name <$> source) - makeNameAliasPair from (Just alias) = (from, alias) - makeNameAliasPair from Nothing = (from, from) - - -- 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) - -debuggerStatement :: Assignment (Term Loc) -debuggerStatement = makeTerm <$> symbol Grammar.DebuggerStatement <*> (TypeScript.Syntax.Debugger <$ rawSource) - -expressionStatement' :: Assignment (Term Loc) -expressionStatement' = symbol ExpressionStatement *> children (term expressions) - -declaration :: Assignment (Term Loc) -declaration = everything - where - everything = choice [ - exportStatement, - importAlias', - function, - internalModule, - ambientFunction, - abstractClass, - class', - module', - variableDeclaration, - typeAliasDeclaration, - enumDeclaration, - interfaceDeclaration, - ambientDeclaration - ] - -typeAliasDeclaration :: Assignment (Term Loc) -typeAliasDeclaration = makeTypeAliasDecl <$> symbol Grammar.TypeAliasDeclaration <*> children ((,,) <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> term ty) - where makeTypeAliasDecl loc (identifier, typeParams, body) = makeTerm loc (Declaration.TypeAlias [typeParams] identifier body) - -enumDeclaration :: Assignment (Term Loc) -enumDeclaration = makeTerm <$> symbol Grammar.EnumDeclaration <*> children (TypeScript.Syntax.EnumDeclaration <$> term identifier <*> (symbol EnumBody *> children (manyTerm (propertyName <|> enumAssignment)))) - -enumAssignment :: Assignment (Term Loc) -enumAssignment = makeTerm <$> symbol Grammar.EnumAssignment <*> children (Statement.Assignment [] <$> term propertyName <*> term expression) - -interfaceDeclaration :: Assignment (Term Loc) -interfaceDeclaration = makeInterfaceDecl <$> symbol Grammar.InterfaceDeclaration <*> children ((,,,) <$> term typeIdentifier <*> (term typeParameters <|> emptyTerm) <*> optional (term extendsClause) <*> term objectType) - where makeInterfaceDecl loc (identifier, typeParams, clause, objectType) = makeTerm loc (Declaration.InterfaceDeclaration [typeParams] identifier (toList clause) objectType) - -ambientDeclaration :: Assignment (Term Loc) -ambientDeclaration = makeTerm <$> symbol Grammar.AmbientDeclaration <*> children (TypeScript.Syntax.AmbientDeclaration <$> term (choice [propertyIdentifier *> ty, declaration, statementBlock])) - -exportStatement :: Assignment (Term Loc) -exportStatement = makeTerm <$> symbol Grammar.ExportStatement <*> children (flip TypeScript.Syntax.QualifiedExportFrom <$> exportClause <*> fromClause) - <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TypeScript.Syntax.QualifiedExport <$> exportClause) - <|> makeTerm <$> symbol Grammar.ExportStatement <*> children (TypeScript.Syntax.DefaultExport <$> contextualize decorator (term (declaration <|> expression <|> identifier <|> importAlias'))) - where - exportClause = symbol Grammar.ExportClause *> children (many exportSymbol) - exportSymbol = symbol Grammar.ExportSpecifier *> children (makeNameAliasPair <$> rawIdentifier <*> (Just <$> rawIdentifier)) - <|> 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 *> (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) - -propertySignature :: Assignment (Term Loc) -propertySignature = makePropertySignature <$> symbol Grammar.PropertySignature <*> children ((,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> term propertyName <*> (term typeAnnotation' <|> emptyTerm)) - where makePropertySignature loc (modifier, readonly, propertyName, annotation) = makeTerm loc (TypeScript.Syntax.PropertySignature [readonly, annotation] propertyName modifier) - -propertyName :: Assignment (Term Loc) -propertyName = term (propertyIdentifier <|> string <|> number <|> computedPropertyName) - -computedPropertyName :: Assignment (Term Loc) -computedPropertyName = makeTerm <$> symbol Grammar.ComputedPropertyName <*> children (TypeScript.Syntax.ComputedPropertyName <$> term expression) - -assignmentPattern :: Assignment (Term Loc) -assignmentPattern = makeTerm <$> symbol AssignmentPattern <*> children (Statement.Assignment [] <$> term shorthandPropertyIdentifier <*> term expression) - -shorthandPropertyIdentifier :: Assignment (Term Loc) -shorthandPropertyIdentifier = makeTerm <$> symbol Grammar.ShorthandPropertyIdentifier <*> (TypeScript.Syntax.ShorthandPropertyIdentifier <$> source) - -requiredParameter :: Assignment (Term Loc) -requiredParameter = makeRequiredParameter - <$> symbol Grammar.RequiredParameter - <*> children ( (,,,,) - <$> accessibilityModifier' - <*> (term readonly' <|> emptyTerm) - <*> term (identifier <|> destructuringPattern <|> this) - <*> (term typeAnnotation' <|> emptyTerm) - <*> (term expression <|> emptyTerm)) - where - makeRequiredParameter loc (modifier, readonly, identifier, annotation, initializer) = makeTerm loc (TypeScript.Syntax.RequiredParameter [readonly, annotation] identifier initializer modifier) - -restParameter :: Assignment (Term Loc) -restParameter = makeRestParameter <$> symbol Grammar.RestParameter <*> children ((,) <$> term identifier <*> (term typeAnnotation' <|> emptyTerm)) - where makeRestParameter loc (identifier, annotation) = makeTerm loc (TypeScript.Syntax.RestParameter [annotation] identifier) - -optionalParameter :: Assignment (Term Loc) -optionalParameter = makeOptionalParam <$> symbol Grammar.OptionalParameter <*> children ((,,,,) <$> accessibilityModifier' <*> (term readonly' <|> emptyTerm) <*> (term identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) - where makeOptionalParam loc (modifier, readonly, subject, annotation, initializer) = makeTerm loc (TypeScript.Syntax.OptionalParameter [readonly, annotation] (makeTerm loc (Statement.Assignment [] subject initializer)) modifier) - -internalModule :: Assignment (Term Loc) -internalModule = makeTerm <$> symbol Grammar.InternalModule <*> children (TypeScript.Syntax.InternalModule <$> term (string <|> identifier <|> nestedIdentifier) <*> statements) - -module' :: Assignment (Term Loc) -module' = makeTerm <$> symbol Module <*> children (TypeScript.Syntax.Module <$> term (string <|> identifier <|> nestedIdentifier) <*> (statements <|> pure [])) - - -statements :: Assignment [Term Loc] -statements = symbol StatementBlock *> children (manyTerm statement) - -arrowFunction :: Assignment (Term Loc) -arrowFunction = makeArrowFun <$> symbol ArrowFunction <*> children ((,,) <$> emptyTerm <*> (((\a b c -> (a, [b], c)) <$> emptyTerm <*> term identifier <*> emptyTerm) <|> callSignatureParts) <*> term (expression <|> statementBlock)) - where makeArrowFun loc (identifier, (typeParams, params, returnTy), body) = makeTerm loc (Declaration.Function [ typeParams, returnTy ] identifier params body) - -comment :: Assignment (Term Loc) -comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) - -ifStatement :: Assignment (Term Loc) -ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term parenthesizedExpression <*> term statement <*> (term statement <|> emptyTerm)) - -whileStatement :: Assignment (Term Loc) -whileStatement = makeTerm <$> symbol WhileStatement <*> children (Statement.While <$> term expression <*> term statement) - -forStatement :: Assignment (Term Loc) -forStatement = makeTerm <$> symbol ForStatement <*> children (Statement.For <$> term (variableDeclaration <|> expressionStatement' <|> emptyStatement) <*> term (expressionStatement' <|> emptyStatement) <*> term (expressions <|> emptyTerm) <*> term statement) - -variableDeclaration :: Assignment (Term Loc) -variableDeclaration = makeTerm <$> (symbol Grammar.VariableDeclaration <|> symbol Grammar.LexicalDeclaration) <*> children (Declaration.VariableDeclaration <$> manyTerm variableDeclarator) - -variableDeclarator :: Assignment (Term Loc) -variableDeclarator = - makeTerm <$> symbol VariableDeclarator <*> children (TypeScript.Syntax.JavaScriptRequire <$> identifier <*> requireCall) - <|> makeVarDecl <$> symbol VariableDeclarator <*> children ((,,) <$> term (identifier <|> destructuringPattern) <*> (term typeAnnotation' <|> emptyTerm) <*> (term expression <|> emptyTerm)) - where - makeVarDecl loc (subject, annotations, value) = makeTerm loc (Statement.Assignment [annotations] subject value) - - requireCall = symbol CallExpression *> children (symbol Identifier *> do - s <- source - guard (s == "require") - symbol Arguments *> children (symbol Grammar.String *> (TypeScript.Resolution.importPath <$> source)) - ) - - -parenthesizedExpression :: Assignment (Term Loc) -parenthesizedExpression = symbol ParenthesizedExpression *> children (term expressions) - -switchStatement :: Assignment (Term Loc) -switchStatement = makeTerm <$> symbol SwitchStatement <*> children (Statement.Match <$> term parenthesizedExpression <*> term switchBody) - where - switchBody = symbol SwitchBody *> children (makeTerm <$> location <*> manyTerm switchCase) - switchCase = makeTerm <$> (symbol SwitchCase <|> symbol SwitchDefault) <*> children (Statement.Pattern <$> (term expressions <|> emptyTerm) <*> (makeTerm <$> location <*> manyTerm statement)) - -subscriptExpression :: Assignment (Term Loc) -subscriptExpression = makeTerm <$> symbol SubscriptExpression <*> children (Expression.Subscript <$> term expression <*> (pure <$> term expressions)) - -pair :: Assignment (Term Loc) -pair = makeTerm <$> symbol Pair <*> children (Literal.KeyValue <$> term propertyName <*> term expression) - -callExpression :: Assignment (Term Loc) -callExpression = makeCall <$> (symbol CallExpression <|> symbol CallExpression') <*> children ((,,,) <$> term (expression <|> super <|> function) <*> (typeArguments <|> pure []) <*> (arguments <|> (pure <$> term templateString)) <*> emptyTerm) - where makeCall loc (subject, typeArgs, args, body) = makeTerm loc (Expression.Call typeArgs subject args body) - typeArguments = symbol Grammar.TypeArguments *> children (some (term ty)) - -arguments :: Assignment [Term Loc] -arguments = symbol Arguments *> children (manyTerm (expression <|> spreadElement)) - -tryStatement :: Assignment (Term Loc) -tryStatement = makeTry <$> symbol TryStatement <*> children ((,,) <$> term statementTerm <*> optional (term catchClause) <*> optional (term finallyClause)) - where - makeTry loc (statementBlock', catch, finally) = makeTerm loc (Statement.Try statementBlock' (catMaybes [catch, finally])) - catchClause = makeTerm <$> symbol CatchClause <*> children (Statement.Catch <$> (identifier <|> emptyTerm) <*> statementTerm) - finallyClause = makeTerm <$> symbol FinallyClause <*> children (Statement.Finally <$> statementTerm) - -binaryExpression :: Assignment (Term Loc) -binaryExpression = makeTerm' <$> symbol BinaryExpression <*> children (infixTerm expression (term expression) - [ (inject .) . Expression.Plus <$ symbol AnonPlus - , (inject .) . Expression.Minus <$ symbol AnonMinus - , (inject .) . Expression.Times <$ symbol AnonStar - , (inject .) . Expression.DividedBy <$ symbol AnonSlash - , (inject .) . Expression.Modulo <$ symbol AnonPercent - , (inject .) . Expression.Member <$ symbol AnonIn - , (inject .) . Expression.And <$ symbol AnonAmpersandAmpersand - , (inject .) . Expression.BAnd <$ symbol AnonAmpersand - , (inject .) . Expression.Or <$ symbol AnonPipePipe - , (inject .) . Expression.BOr <$ symbol AnonPipe - , (inject .) . Expression.BXOr <$ symbol AnonCaret - , (inject .) . Expression.InstanceOf <$ symbol AnonInstanceof - , (inject .) . Expression.Equal <$ symbol AnonEqualEqual - , (inject .) . Expression.StrictEqual <$ symbol AnonEqualEqualEqual - , (inject .) . invert Expression.Equal <$ symbol AnonBangEqual - , (inject .) . invert Expression.StrictEqual <$ symbol AnonBangEqualEqual - , (inject .) . Expression.LShift <$ symbol AnonLAngleLAngle - , (inject .) . Expression.RShift <$ symbol AnonRAngleRAngle - , (inject .) . Expression.UnsignedRShift <$ symbol AnonRAngleRAngleRAngle - , (inject .) . Expression.LessThan <$ symbol AnonLAngle - , (inject .) . Expression.GreaterThan <$ symbol AnonRAngle - , (inject .) . Expression.LessThanEqual <$ symbol AnonLAngleEqual - , (inject .) . Expression.GreaterThanEqual <$ symbol AnonRAngleEqual - ]) - where invert cons a b = Expression.Not (makeTerm1 (cons a b)) - - --- Helpers - --- | Match a term optionally preceded by comment(s), or a sequence of comments if the term is not present. -manyTerm :: Assignment (Term Loc) -> Assignment [Term Loc] -manyTerm term = many (contextualize comment term <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)) - -term :: Assignment (Term Loc) -> Assignment (Term Loc) -term term = contextualize comment (postContextualize comment term) - -emptyStatement :: Assignment (Term Loc) -emptyStatement = makeTerm <$> symbol EmptyStatement <*> (Syntax.Empty <$ rawSource <|> pure Syntax.Empty) - --- | Match infix terms separated by any of a list of operators, assigning any comments following each operand. -infixTerm :: Assignment (Term Loc) - -> Assignment (Term Loc) - -> [Assignment (Term Loc -> Term Loc -> Sum TypeScript.Syntax (Term Loc))] - -> Assignment (Sum TypeScript.Syntax (Term Loc)) -infixTerm = infixContext comment diff --git a/src/Language/TypeScript/Resolution.hs b/src/Language/TypeScript/Resolution.hs deleted file mode 100644 index 1abdc6763c..0000000000 --- a/src/Language/TypeScript/Resolution.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE FlexibleContexts, RecordWildCards #-} -module Language.TypeScript.Resolution - ( ImportPath (..) - , IsRelative (..) - , importPath - , toName - , resolveWithNodejsStrategy - , resolveModule - , resolveNonRelativePath - , javascriptExtensions - , typescriptExtensions - ) where - -import qualified Data.Map as Map -import System.FilePath.Posix - -import Data.Abstract.BaseError -import Data.Abstract.Evaluatable -import qualified Data.Abstract.Module as M -import Data.Abstract.Package -import Data.Abstract.Path -import Data.ImportPath -import qualified Data.Language as Language -import qualified System.Path as Path - --- Node.js resolution algorithm: https://nodejs.org/api/modules.html#modules_all_together --- --- NB: TypeScript has a couple of different strategies, but the main one (and the --- only one we support) mimics Node.js. -resolveWithNodejsStrategy :: ( Has (Modules address value) sig m - , Has (Reader M.ModuleInfo) sig m - , Has (Reader PackageInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - , Has Trace sig m - ) - => ImportPath - -> [String] - -> Evaluator term address value m M.ModulePath -resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath (Path.relDir path) exts -resolveWithNodejsStrategy (ImportPath path _) exts = resolveRelativePath (Path.rel path) exts - --- | Resolve a relative TypeScript import to a known 'ModuleName' or fail. --- --- import { b } from "./moduleB" in /root/src/moduleA.ts --- --- /root/src/moduleB.ts --- /root/src/moduleB/package.json (if it specifies a "types" property) --- /root/src/moduleB/index.ts -resolveRelativePath :: ( Has (Modules address value) sig m - , Has (Reader M.ModuleInfo) sig m - , Has (Reader PackageInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - , Has Trace sig m - ) - => Path.RelFileDir - -> [String] - -> Evaluator term address value m M.ModulePath -resolveRelativePath relImportPath exts = do - M.ModuleInfo{..} <- currentModule - let relRootDir = Path.takeDirectory modulePath - let path = relRootDir `joinPaths` relImportPath - trace ("attempting to resolve (relative) require/import " <> show relImportPath) - resolveModule path exts >>= either notFound (\x -> x <$ traceResolve relImportPath path) - where - notFound xs = throwResolutionError $ NotFoundError (Path.toAbsRel relImportPath) xs Language.TypeScript - --- | Resolve a non-relative TypeScript import to a known 'ModuleName' or fail. --- --- import { b } from "moduleB" in source file /root/src/moduleA.ts --- --- /root/src/node_modules/moduleB.ts --- /root/src/node_modules/moduleB/package.json (if it specifies a "types" property) --- /root/src/node_modules/moduleB/index.ts --- --- /root/node_modules/moduleB.ts, etc --- /node_modules/moduleB.ts, etc --- TODO: The NonRelative package means the packages in node_modules, --- laying relatively in filesystem under the project root. Perhaps we --- can rename the function like resolvePackagePath to resolve the --- confusion between Path.RelDir and NonRelative. -resolveNonRelativePath :: ( Has (Modules address value) sig m - , Has (Reader M.ModuleInfo) sig m - , Has (Reader PackageInfo) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError ResolutionError)) sig m - , Has Trace sig m - ) - => Path.RelDir - -> [String] - -> Evaluator term address value m M.ModulePath -resolveNonRelativePath name exts = do - M.ModuleInfo{..} <- currentModule - go (Path.toAbsRel Path.currentDir) (Path.takeDirectory modulePath) mempty - where - nodeModulesPath dir = dir Path. Path.relDir "node_modules" Path. name - -- Recursively search in a 'node_modules' directory, stepping up a directory each time. - go root path searched = do - trace ("attempting to resolve (non-relative) require/import " <> show name) - res <- resolveModule (Path.toFileDir $ nodeModulesPath path) exts - case res of - Left xs | Just parentDir <- Path.takeSuperDirectory path , root /= path -> go root parentDir (searched <> xs) - | otherwise -> notFound (searched <> xs) - Right m -> m <$ traceResolve name m - notFound xs = throwResolutionError $ NotFoundError (Path.toAbsRel $ Path.toFileDir name) xs Language.TypeScript - --- | Resolve a module name to a ModulePath. -resolveModule :: ( Has (Modules address value) sig m - , Has (Reader PackageInfo) sig m - , Has Trace sig m - ) - => Path.AbsRelFileDir -- ^ Module path used as directory to search in - -> [String] -- ^ File extensions to look for - -> Evaluator term address value m (Either [M.ModulePath] M.ModulePath) -resolveModule path' exts = do - let path = makeRelative "." $ Path.toString path' - PackageInfo{..} <- currentPackage - let packageDotJSON = Map.lookup (path "package.json") packageResolutions - let searchPaths' = ((path <.>) <$> exts) - <> maybe mempty (:[]) packageDotJSON - <> (((path "index") <.>) <$> exts) - let searchPaths = fmap Path.absRel searchPaths' - trace ("searching in " <> show searchPaths) - maybe (Left searchPaths) Right <$> resolve searchPaths - -typescriptExtensions :: [String] -typescriptExtensions = ["ts", "tsx", "d.ts"] - -javascriptExtensions :: [String] -javascriptExtensions = ["js"] diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs deleted file mode 100644 index e18502279a..0000000000 --- a/src/Language/TypeScript/Syntax.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Language.TypeScript.Syntax ( module X ) where - -import Language.TypeScript.Syntax.Import as X -import Language.TypeScript.Syntax.JavaScript as X -import Language.TypeScript.Syntax.TypeScript as X -import Language.TypeScript.Syntax.Types as X diff --git a/src/Language/TypeScript/Syntax/Import.hs b/src/Language/TypeScript/Syntax/Import.hs deleted file mode 100644 index 1045d0628e..0000000000 --- a/src/Language/TypeScript/Syntax/Import.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -module Language.TypeScript.Syntax.Import (module Language.TypeScript.Syntax.Import) where - -import qualified Analysis.Name as Name -import Control.Abstract hiding (Import) -import Control.Monad -import Data.Abstract.Evaluatable as Evaluatable -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Aeson (ToJSON) -import Data.Foldable -import Data.Functor.Classes.Generic -import Data.Hashable -import Data.Hashable.Lifted -import qualified Data.Map.Strict as Map -import GHC.Generics (Generic, Generic1) -import Language.TypeScript.Resolution -import Source.Span - -data Import a = Import { importSymbols :: ![Alias], importFrom :: ImportPath } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Import where liftEq = genericLiftEq -instance Ord1 Import where liftCompare = genericLiftCompare -instance Show1 Import where liftShowsPrec = genericLiftShowsPrec - - -- http://www.typescriptlang.org/docs/handbook/module-resolution.html -instance Evaluatable Import where - eval _ _ (Import symbols importPath) = do - modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - ((moduleScope, moduleFrame), _) <- require modulePath - if Prelude.null symbols then do - insertImportEdge moduleScope - insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - else do - let scopeEdges = Map.singleton ScopeGraph.Import [ moduleScope ] - scopeAddress <- newScope scopeEdges - let frameLinks = Map.singleton ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - frameAddress <- newFrame scopeAddress frameLinks - - -- Insert import references into the import scope starting from the perspective of the import scope. - withScopeAndFrame moduleFrame $ do - for_ symbols $ \Alias{..} -> - -- TODO: Need an easier way to get the span of an Alias. It's difficult because we no longer have a term. - -- Even if we had one we'd have to evaluate it at the moment. - insertImportReference (Reference aliasName) (point (Pos 1 1)) ScopeGraph.Identifier (Declaration aliasValue) scopeAddress - - -- Create edges from the current scope/frame to the import scope/frame. - insertImportEdge scopeAddress - insertFrameLink ScopeGraph.Import (Map.singleton scopeAddress frameAddress) - unit - -data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq -instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare -instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QualifiedAliasedImport where - eval _ _ (QualifiedAliasedImport aliasTerm importPath) = do - modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - ((moduleScope, moduleFrame), _) <- require modulePath - span <- ask @Span - - importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ]) - let scopeMap = Map.singleton moduleScope moduleFrame - aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap) - name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope) - aliasSlot <- lookupSlot (Declaration name) - assign aliasSlot =<< object aliasFrame - - unit - -newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 SideEffectImport where liftEq = genericLiftEq -instance Ord1 SideEffectImport where liftCompare = genericLiftCompare -instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable SideEffectImport where - eval _ _ (SideEffectImport importPath) = do - modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - void $ require modulePath - unit - --- | Qualified Export declarations -newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [Alias] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 QualifiedExport where liftEq = genericLiftEq -instance Ord1 QualifiedExport where liftCompare = genericLiftCompare -instance Show1 QualifiedExport where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QualifiedExport where - eval _ _ (QualifiedExport exportSymbols) = do - -- Create a Lexical edge from the qualifed export's scope to the current scope. - currentScopeAddress <- currentScope - let edges = Map.singleton Lexical [ currentScopeAddress ] - exportScope <- newScope edges - insertExportEdge exportScope -- Create an export edge from the current scope to the export scope - withScope exportScope . - for_ exportSymbols $ \Alias{..} -> do - -- TODO: Replace Alias in QualifedExport with terms and use a real span - reference (Reference aliasName) (point (Pos 1 1)) ScopeGraph.Identifier (Declaration aliasValue) - - -- Create an export edge from a new scope to the qualifed export's scope. - unit - -data Alias = Alias { aliasValue :: Name, aliasName :: Name } - deriving (Eq, Generic, Hashable, Ord, Show, ToJSON) - -toTuple :: Alias -> (Name, Name) -toTuple Alias{..} = (aliasValue, aliasName) - --- | Qualified Export declarations that export from another module. -data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: ImportPath, qualifiedExportFromSymbols :: ![Alias]} - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq -instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare -instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable QualifiedExportFrom where - eval _ _ (QualifiedExportFrom importPath exportSymbols) = do - modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions - - ((moduleScope, moduleFrame), _) <- require modulePath - exportScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ]) - exportFrame <- newFrame exportScope (Map.singleton ScopeGraph.Import (Map.singleton moduleScope moduleFrame)) - - withScopeAndFrame moduleFrame . - for_ exportSymbols $ \Alias{..} -> do - -- TODO: Replace Alias with terms in QualifiedExportFrom and use a real span below. - insertImportReference (Reference aliasName) (point (Pos 1 1)) ScopeGraph.Identifier (Declaration aliasValue) exportScope - - insertExportEdge exportScope - insertFrameLink ScopeGraph.Export (Map.singleton exportScope exportFrame) - - unit - -newtype DefaultExport a = DefaultExport { defaultExport :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 DefaultExport where liftEq = genericLiftEq -instance Ord1 DefaultExport where liftCompare = genericLiftCompare -instance Show1 DefaultExport where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable DefaultExport where - eval eval _ (DefaultExport term) = do - case declaredName term of - Just _ -> do - exportScope <- newScope mempty - exportFrame <- newFrame exportScope mempty - exportSpan <- ask @Span - withScopeAndFrame exportFrame $ do - valueRef <- eval term - let declaration = Declaration $ Name.name "__default" - declare declaration Default Public exportSpan ScopeGraph.DefaultExport Nothing - defaultSlot <- lookupSlot declaration - assign defaultSlot valueRef - - insertExportEdge exportScope - insertFrameLink ScopeGraph.Export (Map.singleton exportScope exportFrame) - Nothing -> throwEvalError DefaultExportError - unit - -data ImportRequireClause a = ImportRequireClause { importRequireIdentifier :: !a, importRequireSubject :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ImportRequireClause where liftEq = genericLiftEq -instance Ord1 ImportRequireClause where liftCompare = genericLiftCompare -instance Show1 ImportRequireClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ImportRequireClause - -newtype ImportClause a = ImportClause { importClauseElements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ImportClause where liftEq = genericLiftEq -instance Ord1 ImportClause where liftCompare = genericLiftCompare -instance Show1 ImportClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ImportClause - -data ImportAlias a = ImportAlias { importAliasSubject :: !a, importAlias :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ImportAlias where liftEq = genericLiftEq -instance Ord1 ImportAlias where liftCompare = genericLiftCompare -instance Show1 ImportAlias where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ImportAlias diff --git a/src/Language/TypeScript/Syntax/JavaScript.hs b/src/Language/TypeScript/Syntax/JavaScript.hs deleted file mode 100644 index 95bff3e5d3..0000000000 --- a/src/Language/TypeScript/Syntax/JavaScript.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -module Language.TypeScript.Syntax.JavaScript (module Language.TypeScript.Syntax.JavaScript) where - -import Control.Abstract.Heap -import Control.Abstract.ScopeGraph hiding (Import) -import Data.Abstract.Evaluatable -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import qualified Data.Map.Strict as Map -import GHC.Generics (Generic1) -import Language.TypeScript.Resolution - -newtype ImplementsClause a = ImplementsClause { implementsClauseTypes :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ImplementsClause where liftEq = genericLiftEq -instance Ord1 ImplementsClause where liftCompare = genericLiftCompare -instance Show1 ImplementsClause where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ImplementsClause - -data OptionalParameter a = OptionalParameter { optionalParameterContext :: ![a], optionalParameterSubject :: !a, optionalParameterAccessControl :: AccessControl } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 OptionalParameter where liftEq = genericLiftEq -instance Ord1 OptionalParameter where liftCompare = genericLiftCompare -instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable OptionalParameter - -data RequiredParameter a = RequiredParameter { requiredParameterContext :: [a], requiredParameterSubject :: a, requiredParameterValue :: a, requiredParameterAccessControl :: AccessControl } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 RequiredParameter where liftEq = genericLiftEq -instance Ord1 RequiredParameter where liftCompare = genericLiftCompare -instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 RequiredParameter where - liftDeclaredName declaredName RequiredParameter{..} = declaredName requiredParameterSubject - -instance Evaluatable RequiredParameter where - eval eval ref RequiredParameter{..} = do - span <- ask @Span - _ <- declareMaybeName (declaredName requiredParameterSubject) Default Public span ScopeGraph.RequiredParameter Nothing - - lhs <- ref requiredParameterSubject - rhs <- eval requiredParameterValue - - case declaredName requiredParameterValue of - Just rhsName -> do - assocScope <- associatedScope (Declaration rhsName) - case assocScope of - Just assocScope' -> do - objectScope <- newScope (Map.singleton ScopeGraph.Import [ assocScope' ]) - putSlotDeclarationScope lhs (Just objectScope) -- TODO: not sure if this is right - Nothing -> - pure () - Nothing -> - pure () - assign lhs rhs - pure rhs - -data RestParameter a = RestParameter { restParameterContext :: ![a], restParameterSubject :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 RestParameter where liftEq = genericLiftEq -instance Ord1 RestParameter where liftCompare = genericLiftCompare -instance Show1 RestParameter where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable RestParameter - - -data JavaScriptRequire a = JavaScriptRequire { javascriptRequireIden :: !a, javascriptRequireFrom :: ImportPath } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 JavaScriptRequire where liftEq = genericLiftEq -instance Ord1 JavaScriptRequire where liftCompare = genericLiftCompare -instance Show1 JavaScriptRequire where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable JavaScriptRequire where - eval _ _ (JavaScriptRequire aliasTerm importPath) = do - modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions - ((moduleScope, moduleFrame), _) <- require modulePath - - case declaredName aliasTerm of - Just alias -> do - span <- ask @Span - importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ]) - declare (Declaration alias) Default Public span ScopeGraph.UnqualifiedImport (Just importScope) - let scopeMap = Map.singleton moduleScope moduleFrame - aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap) - aliasSlot <- lookupSlot (Declaration alias) - assign aliasSlot =<< object aliasFrame - Nothing -> do - insertImportEdge moduleScope - insertFrameLink ScopeGraph.Import (Map.singleton moduleScope moduleFrame) - unit - -data Debugger a = Debugger - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Debugger where liftEq = genericLiftEq -instance Ord1 Debugger where liftCompare = genericLiftCompare -instance Show1 Debugger where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Debugger - -data Super a = Super - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Super where liftEq = genericLiftEq -instance Ord1 Super where liftCompare = genericLiftCompare -instance Show1 Super where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Super - -data Undefined a = Undefined - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Undefined where liftEq = genericLiftEq -instance Ord1 Undefined where liftCompare = genericLiftCompare -instance Show1 Undefined where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Undefined - -data With a = With { withExpression :: !a, withBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 With where liftEq = genericLiftEq -instance Ord1 With where liftCompare = genericLiftCompare -instance Show1 With where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable With - --- | A sequence expression such as Javascript or C's comma operator. -data AnnotatedExpression a = AnnotatedExpression { expression :: !a, typeAnnotation :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 AnnotatedExpression where liftEq = genericLiftEq -instance Ord1 AnnotatedExpression where liftCompare = genericLiftCompare -instance Show1 AnnotatedExpression where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable AnnotatedExpression where - eval eval _ (AnnotatedExpression a b) = eval b >> eval a diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs deleted file mode 100644 index 5d4e188bc7..0000000000 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ /dev/null @@ -1,384 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -module Language.TypeScript.Syntax.TypeScript (module Language.TypeScript.Syntax.TypeScript) where - -import Control.Abstract hiding (Import) -import Control.Monad -import Data.Abstract.Evaluatable as Evaluatable -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Foldable -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import Data.List.NonEmpty (nonEmpty) -import qualified Data.Map.Strict as Map -import Data.Maybe.Exts -import Data.Semigroup.App -import Data.Semigroup.Foldable -import qualified Data.Text as T -import Data.Traversable -import GHC.Generics (Generic1) - --- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo } -newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier { contents :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ShorthandPropertyIdentifier where liftEq = genericLiftEq -instance Ord1 ShorthandPropertyIdentifier where liftCompare = genericLiftCompare -instance Show1 ShorthandPropertyIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ShorthandPropertyIdentifier - -data Union a = Union { unionLeft :: !a, unionRight :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Union where liftEq = genericLiftEq -instance Ord1 Union where liftCompare = genericLiftCompare -instance Show1 Union where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Language.TypeScript.Syntax.TypeScript.Union - -data Intersection a = Intersection { intersectionLeft :: !a, intersectionRight :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Intersection where liftEq = genericLiftEq -instance Ord1 Intersection where liftCompare = genericLiftCompare -instance Show1 Intersection where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Intersection - -data AmbientFunction a = AmbientFunction { ambientFunctionContext :: ![a], ambientFunctionIdentifier :: !a, ambientFunctionParameters :: ![a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 AmbientFunction where liftEq = genericLiftEq -instance Ord1 AmbientFunction where liftCompare = genericLiftCompare -instance Show1 AmbientFunction where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable AmbientFunction - -newtype Tuple a = Tuple { tupleElements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Tuple where liftEq = genericLiftEq -instance Ord1 Tuple where liftCompare = genericLiftCompare -instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec - --- This is a tuple type, not a tuple value, so we can't lean on the shared Tuple value -instance Evaluatable Tuple - -data Constructor a = Constructor { constructorTypeParameters :: !a, constructorFormalParameters :: ![a], constructorType :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Constructor where liftEq = genericLiftEq -instance Ord1 Constructor where liftCompare = genericLiftCompare -instance Show1 Constructor where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Language.TypeScript.Syntax.TypeScript.Constructor - - -newtype Annotation a = Annotation { annotationType :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Annotation where liftEq = genericLiftEq -instance Ord1 Annotation where liftCompare = genericLiftCompare -instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Annotation - -newtype Decorator a = Decorator { decoratorTerm :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Decorator where liftEq = genericLiftEq -instance Ord1 Decorator where liftCompare = genericLiftCompare -instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Decorator - -newtype ComputedPropertyName a = ComputedPropertyName { propertyName :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ComputedPropertyName where liftEq = genericLiftEq -instance Ord1 ComputedPropertyName where liftCompare = genericLiftCompare -instance Show1 ComputedPropertyName where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ComputedPropertyName - -newtype Constraint a = Constraint { constraintType :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Constraint where liftEq = genericLiftEq -instance Ord1 Constraint where liftCompare = genericLiftCompare -instance Show1 Constraint where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Constraint - -data NestedIdentifier a = NestedIdentifier { left :: !a, right :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NestedIdentifier where liftEq = genericLiftEq -instance Ord1 NestedIdentifier where liftCompare = genericLiftCompare -instance Show1 NestedIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NestedIdentifier - -newtype AmbientDeclaration a = AmbientDeclaration { ambientDeclarationBody :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 AmbientDeclaration where liftEq = genericLiftEq -instance Ord1 AmbientDeclaration where liftCompare = genericLiftCompare -instance Show1 AmbientDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable AmbientDeclaration where - eval eval _ (AmbientDeclaration body) = eval body - -data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, enumDeclarationBody :: ![a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 EnumDeclaration where liftEq = genericLiftEq -instance Ord1 EnumDeclaration where liftCompare = genericLiftCompare -instance Show1 EnumDeclaration where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable EnumDeclaration - -instance Declarations a => Declarations (EnumDeclaration a) where - declaredName EnumDeclaration{..} = declaredName enumDeclarationIdentifier - -newtype ExtendsClause a = ExtendsClause { extendsClauses :: [a] } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ExtendsClause where liftEq = genericLiftEq -instance Ord1 ExtendsClause where liftCompare = genericLiftCompare -instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 ExtendsClause where - liftDeclaredName _ (ExtendsClause []) = Nothing - liftDeclaredName declaredName (ExtendsClause (x : _)) = declaredName x - --- TODO: ExtendsClause shouldn't evaluate to an address in the heap? -instance Evaluatable ExtendsClause where - eval eval _ ExtendsClause{..} = do - -- Evaluate subterms - traverse_ eval extendsClauses - unit - -data PropertySignature a = PropertySignature { modifiers :: [a], propertySignaturePropertyName :: a, propertySignatureAccessControl :: AccessControl } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 PropertySignature where liftEq = genericLiftEq -instance Ord1 PropertySignature where liftCompare = genericLiftCompare -instance Show1 PropertySignature where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable PropertySignature - -data CallSignature a = CallSignature { callSignatureTypeParameters :: !a, callSignatureParameters :: ![a], callSignatureType :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 CallSignature where liftEq = genericLiftEq -instance Ord1 CallSignature where liftCompare = genericLiftCompare -instance Show1 CallSignature where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable CallSignature - --- | Todo: Move type params and type to context -data ConstructSignature a = ConstructSignature { constructSignatureTypeParameters :: !a, constructSignatureParameters :: ![a], constructSignatureType :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ConstructSignature where liftEq = genericLiftEq -instance Ord1 ConstructSignature where liftCompare = genericLiftCompare -instance Show1 ConstructSignature where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ConstructSignature - -data IndexSignature a = IndexSignature { subject :: a, subjectType :: a, typeAnnotation :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 IndexSignature where liftEq = genericLiftEq -instance Ord1 IndexSignature where liftCompare = genericLiftCompare -instance Show1 IndexSignature where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable IndexSignature - -data AbstractMethodSignature a = AbstractMethodSignature { abstractMethodSignatureContext :: ![a], abstractMethodSignatureName :: a, abstractMethodSignatureParameters :: [a], abstractMethodAccessControl :: AccessControl } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 AbstractMethodSignature where liftEq = genericLiftEq -instance Ord1 AbstractMethodSignature where liftCompare = genericLiftCompare -instance Show1 AbstractMethodSignature where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable AbstractMethodSignature - -data ForOf a = ForOf { forOfBinding :: !a, forOfSubject :: !a, forOfBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ForOf where liftEq = genericLiftEq -instance Ord1 ForOf where liftCompare = genericLiftCompare -instance Show1 ForOf where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ForOf - -data LabeledStatement a = LabeledStatement { labeledStatementIdentifier :: !a, labeledStatementSubject :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 LabeledStatement where liftEq = genericLiftEq -instance Ord1 LabeledStatement where liftCompare = genericLiftCompare -instance Show1 LabeledStatement where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LabeledStatement - -newtype Update a = Update { updateSubject :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Update where liftEq = genericLiftEq -instance Ord1 Update where liftCompare = genericLiftCompare -instance Show1 Update where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable Update - -data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 Module where liftEq = genericLiftEq -instance Ord1 Module where liftCompare = genericLiftCompare -instance Show1 Module where liftShowsPrec = genericLiftShowsPrec - -declareModule :: ( AbstractValue term address value m - , Declarations term - , Has (Allocator address) sig m - , Has (Deref value) sig m - , Has (Object address value) sig m - , Has (Reader (CurrentFrame address)) sig m - , Has (Reader (CurrentScope address)) sig m - , Has (Reader Span) sig m - , Has (Resumable (BaseError (EvalError term address value))) sig m - , Has (State (Heap address address value)) sig m - , Has (State (ScopeGraph address)) sig m - , Has Fresh sig m - , Has (Reader ModuleInfo) sig m - , Has (Resumable (BaseError (AddressError address value))) sig m - , Has (Resumable (BaseError (HeapError address))) sig m - , Has (Resumable (BaseError (ScopeError address))) sig m - , Has (Unit value) sig m - , Ord address - ) - => (term -> Evaluator term address value m value) - -> term - -> [term] - -> Evaluator term address value m value -declareModule eval identifier statements = do - (name, relation) <- case declaredName identifier of - Just name -> pure (name, Default) - _ -> gensym >>= \name -> pure (name, Gensym) - span <- ask @Span - currentScope' <- currentScope - - let declaration = Declaration name - moduleBody = maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty statements) - maybeSlot <- maybeLookupDeclaration declaration - - case maybeSlot of - Just slot -> do - moduleVal <- deref slot - maybeFrame <- scopedEnvironment moduleVal - case maybeFrame of - Just moduleFrame -> do - withScopeAndFrame moduleFrame moduleBody - Nothing -> throwEvalError (DerefError moduleVal) - Nothing -> do - let edges = Map.singleton Lexical [ currentScope' ] - childScope <- newScope edges - declare (Declaration name) relation Public span ScopeGraph.Module (Just childScope) - - currentFrame' <- currentFrame - let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame') - childFrame <- newFrame childScope frameEdges - - withScopeAndFrame childFrame (void moduleBody) - - moduleSlot <- lookupSlot (Declaration name) - assign moduleSlot =<< namespace name childFrame - - unit - -instance Evaluatable Module where - eval eval _ Module{..} = declareModule eval moduleIdentifier moduleStatements - -instance Declarations1 Module where - liftDeclaredName declaredName = declaredName . moduleIdentifier - -data InternalModule a = InternalModule { internalModuleIdentifier :: !a, internalModuleStatements :: ![a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 InternalModule where liftEq = genericLiftEq -instance Ord1 InternalModule where liftCompare = genericLiftCompare -instance Show1 InternalModule where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable InternalModule where - eval eval _ InternalModule{..} = - declareModule eval internalModuleIdentifier internalModuleStatements - -instance Declarations a => Declarations (InternalModule a) where - declaredName InternalModule{..} = declaredName internalModuleIdentifier - -data ClassHeritage a = ClassHeritage { classHeritageExtendsClause :: !a, implementsClause :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ClassHeritage where liftEq = genericLiftEq -instance Ord1 ClassHeritage where liftCompare = genericLiftCompare -instance Show1 ClassHeritage where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ClassHeritage - -data AbstractClass a = AbstractClass { abstractClassIdentifier :: !a, abstractClassTypeParameters :: !a, classHeritage :: ![a], classBody :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 AbstractClass where liftEq = genericLiftEq -instance Ord1 AbstractClass where liftCompare = genericLiftCompare -instance Show1 AbstractClass where liftShowsPrec = genericLiftShowsPrec - -instance Declarations a => Declarations (AbstractClass a) where - declaredName AbstractClass{..} = declaredName abstractClassIdentifier - -instance Evaluatable AbstractClass where - eval eval _ AbstractClass{..} = do - span <- ask @Span - currentScope' <- currentScope - - superScopes <- for classHeritage $ \superclass -> do - name <- maybeM (throwNoNameError superclass) (declaredName superclass) - scope <- associatedScope (Declaration name) - slot <- lookupSlot (Declaration name) - superclassFrame <- scopedEnvironment =<< deref slot - pure $ case (scope, superclassFrame) of - (Just scope, Just frame) -> Just (scope, frame) - _ -> Nothing - - let superclassEdges = (Superclass, ) . pure . fst <$> catMaybes superScopes - current = (Lexical, ) <$> pure (pure currentScope') - edges = Map.fromList (superclassEdges <> current) - classScope <- newScope edges - name <- declareMaybeName (declaredName abstractClassIdentifier) Default Public span ScopeGraph.AbstractClass (Just classScope) - - let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes)) - childFrame <- newFrame classScope frameEdges - - withScopeAndFrame childFrame $ do - void $ eval classBody - - classSlot <- lookupSlot (Declaration name) - assign classSlot =<< klass (Declaration name) childFrame - - unit - -data MetaProperty a = MetaProperty - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 MetaProperty where liftEq = genericLiftEq -instance Ord1 MetaProperty where liftCompare = genericLiftCompare -instance Show1 MetaProperty where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable MetaProperty diff --git a/src/Language/TypeScript/Syntax/Types.hs b/src/Language/TypeScript/Syntax/Types.hs deleted file mode 100644 index 028dfb154f..0000000000 --- a/src/Language/TypeScript/Syntax/Types.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -module Language.TypeScript.Syntax.Types (module Language.TypeScript.Syntax.Types) where - -import Control.Abstract hiding (Import) -import Data.Abstract.Evaluatable as Evaluatable -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Functor.Classes.Generic -import Data.Hashable.Lifted -import qualified Data.Text as T -import GHC.Generics (Generic1) - --- | Lookup type for a type-level key in a typescript map. -data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 LookupType where liftEq = genericLiftEq -instance Ord1 LookupType where liftCompare = genericLiftCompare -instance Show1 LookupType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LookupType - -data FunctionType a = FunctionType { functionTypeParameters :: !a, functionFormalParameters :: ![a], functionType :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 FunctionType where liftEq = genericLiftEq -instance Ord1 FunctionType where liftCompare = genericLiftCompare -instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FunctionType - -data TypeParameter a = TypeParameter { typeParameter :: !a, typeParameterConstraint :: !a, typeParameterDefaultType :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeParameter where liftEq = genericLiftEq -instance Ord1 TypeParameter where liftCompare = genericLiftCompare -instance Show1 TypeParameter where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeParameter - -data TypeAssertion a = TypeAssertion { typeAssertionParameters :: !a, typeAssertionExpression :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeAssertion where liftEq = genericLiftEq -instance Ord1 TypeAssertion where liftCompare = genericLiftCompare -instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeAssertion - -newtype DefaultType a = DefaultType { defaultType :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 DefaultType where liftEq = genericLiftEq -instance Ord1 DefaultType where liftCompare = genericLiftCompare -instance Show1 DefaultType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable DefaultType - -newtype ParenthesizedType a = ParenthesizedType { parenthesizedType :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ParenthesizedType where liftEq = genericLiftEq -instance Ord1 ParenthesizedType where liftCompare = genericLiftCompare -instance Show1 ParenthesizedType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ParenthesizedType - -newtype PredefinedType a = PredefinedType { predefinedType :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -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 } - deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeIdentifier where liftEq = genericLiftEq -instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare -instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Declarations1 TypeIdentifier where - liftDeclaredName _ (TypeIdentifier identifier) = Just (Evaluatable.name identifier) - --- 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. - span <- ask @Span - reference (Reference (Evaluatable.name contents)) span ScopeGraph.TypeIdentifier (Declaration (Evaluatable.name contents)) - unit - -data NestedTypeIdentifier a = NestedTypeIdentifier { left :: !a, right :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 NestedTypeIdentifier where liftEq = genericLiftEq -instance Ord1 NestedTypeIdentifier where liftCompare = genericLiftCompare -instance Show1 NestedTypeIdentifier where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable NestedTypeIdentifier - -data GenericType a = GenericType { genericTypeIdentifier :: !a, genericTypeArguments :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 GenericType where liftEq = genericLiftEq -instance Ord1 GenericType where liftCompare = genericLiftCompare -instance Show1 GenericType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable GenericType - -data TypePredicate a = TypePredicate { typePredicateIdentifier :: !a, typePredicateType :: !a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypePredicate where liftEq = genericLiftEq -instance Ord1 TypePredicate where liftCompare = genericLiftCompare -instance Show1 TypePredicate where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypePredicate - -newtype ObjectType a = ObjectType { objectTypeElements :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ObjectType where liftEq = genericLiftEq -instance Ord1 ObjectType where liftCompare = genericLiftCompare -instance Show1 ObjectType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ObjectType - -newtype ArrayType a = ArrayType { arrayType :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ArrayType where liftEq = genericLiftEq -instance Ord1 ArrayType where liftCompare = genericLiftCompare -instance Show1 ArrayType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ArrayType - -newtype FlowMaybeType a = FlowMaybeType { flowMaybeType :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 FlowMaybeType where liftEq = genericLiftEq -instance Ord1 FlowMaybeType where liftCompare = genericLiftCompare -instance Show1 FlowMaybeType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable FlowMaybeType - -newtype TypeQuery a = TypeQuery { typeQuerySubject :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeQuery where liftEq = genericLiftEq -instance Ord1 TypeQuery where liftCompare = genericLiftCompare -instance Show1 TypeQuery where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeQuery - -newtype IndexTypeQuery a = IndexTypeQuery { indexTypeQuerySubject :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 IndexTypeQuery where liftEq = genericLiftEq -instance Ord1 IndexTypeQuery where liftCompare = genericLiftCompare -instance Show1 IndexTypeQuery where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable IndexTypeQuery - -newtype TypeArguments a = TypeArguments { typeArguments :: [a] } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 TypeArguments where liftEq = genericLiftEq -instance Ord1 TypeArguments where liftCompare = genericLiftCompare -instance Show1 TypeArguments where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable TypeArguments - -newtype ThisType a = ThisType { contents :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ThisType where liftEq = genericLiftEq -instance Ord1 ThisType where liftCompare = genericLiftCompare -instance Show1 ThisType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ThisType - -newtype ExistentialType a = ExistentialType { contents :: T.Text } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 ExistentialType where liftEq = genericLiftEq -instance Ord1 ExistentialType where liftCompare = genericLiftCompare -instance Show1 ExistentialType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable ExistentialType - -newtype LiteralType a = LiteralType { literalTypeSubject :: a } - deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable) - -instance Eq1 LiteralType where liftEq = genericLiftEq -instance Ord1 LiteralType where liftCompare = genericLiftCompare -instance Show1 LiteralType where liftShowsPrec = genericLiftShowsPrec - -instance Evaluatable LiteralType diff --git a/src/Language/TypeScript/Term.hs b/src/Language/TypeScript/Term.hs deleted file mode 100644 index 7f097b49ca..0000000000 --- a/src/Language/TypeScript/Term.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, RecordWildCards, TypeFamilies #-} -module Language.TypeScript.Term -( Syntax -, Term(..) -) where - -import Control.Lens.Lens -import Data.Abstract.Declarations -import Data.Abstract.FreeVariables -import Data.Bitraversable -import Data.Coerce -import Data.Foldable (fold) -import Data.Functor.Foldable (Base, Recursive(..)) -import Data.Graph.ControlFlowVertex (VertexDeclaration(..), toVertex1) -import qualified Data.Sum as Sum -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Expression as Expression -import qualified Data.Syntax.Literal as Literal -import qualified Data.Syntax.Statement as Statement -import qualified Data.Syntax.Type as Type -import qualified Data.Term as Term -import Data.Traversable -import qualified Language.TypeScript.Syntax as TypeScript.Syntax -import Source.Loc -import Source.Span - -type Syntax = - [ Comment.Comment - , Comment.HashBang - , Declaration.Class - , Declaration.Function - , Declaration.Method - , Declaration.MethodSignature - , Declaration.InterfaceDeclaration - , Declaration.PublicFieldDefinition - , Declaration.VariableDeclaration - , Declaration.TypeAlias - , Expression.Plus - , Expression.Minus - , Expression.Times - , Expression.DividedBy - , Expression.Modulo - , Expression.Power - , Expression.Negate - , Expression.FloorDivision - , Expression.BAnd - , Expression.BOr - , Expression.BXOr - , Expression.LShift - , Expression.RShift - , Expression.UnsignedRShift - , Expression.Complement - , Expression.And - , Expression.Not - , Expression.Or - , Expression.XOr - , Expression.Call - , Expression.Cast - , Expression.LessThan - , Expression.LessThanEqual - , Expression.GreaterThan - , Expression.GreaterThanEqual - , Expression.Equal - , Expression.StrictEqual - , Expression.Comparison - , Expression.Enumeration - , Expression.MemberAccess - , Expression.NonNullExpression - , Expression.ScopeResolution - , Expression.SequenceExpression - , Expression.Subscript - , Expression.Member - , Expression.Delete - , Expression.Void - , Expression.Typeof - , Expression.InstanceOf - , Expression.New - , Expression.Await - , Expression.This - , Literal.Array - , Literal.Boolean - , Literal.Float - , Literal.Hash - , Literal.Integer - , Literal.KeyValue - , Literal.Null - , Literal.String - , Literal.TextElement - , Literal.Regex - , Statement.Assignment - , Statement.AugmentedAssignment - , Statement.Break - , Statement.Catch - , Statement.Continue - , Statement.DoWhile - , Statement.Else - , Statement.Finally - , Statement.For - , Statement.ForEach - , Statement.If - , Statement.Match - , Statement.Pattern - , Statement.Retry - , Statement.Return - , Statement.ScopeEntry - , Statement.ScopeExit - , Statement.Statements - , Statement.Throw - , Statement.Try - , Statement.While - , Statement.Yield - , Syntax.AccessibilityModifier - , Syntax.Empty - , Syntax.Error - , Syntax.Identifier - , Syntax.Context - , Type.Readonly - , Type.TypeParameters - , TypeScript.Syntax.TypeParameter - , TypeScript.Syntax.Constraint - , TypeScript.Syntax.ParenthesizedType - , TypeScript.Syntax.DefaultType - , TypeScript.Syntax.PredefinedType - , TypeScript.Syntax.TypeIdentifier - , TypeScript.Syntax.NestedIdentifier - , TypeScript.Syntax.NestedTypeIdentifier - , TypeScript.Syntax.GenericType - , TypeScript.Syntax.TypeArguments - , TypeScript.Syntax.TypePredicate - , TypeScript.Syntax.CallSignature - , TypeScript.Syntax.ConstructSignature - , TypeScript.Syntax.ArrayType - , TypeScript.Syntax.LookupType - , TypeScript.Syntax.FlowMaybeType - , TypeScript.Syntax.TypeQuery - , TypeScript.Syntax.IndexTypeQuery - , TypeScript.Syntax.ThisType - , TypeScript.Syntax.ExistentialType - , TypeScript.Syntax.AbstractMethodSignature - , TypeScript.Syntax.IndexSignature - , TypeScript.Syntax.ObjectType - , TypeScript.Syntax.LiteralType - , TypeScript.Syntax.Union - , TypeScript.Syntax.Intersection - , TypeScript.Syntax.Module - , TypeScript.Syntax.InternalModule - , TypeScript.Syntax.FunctionType - , TypeScript.Syntax.Tuple - , TypeScript.Syntax.Constructor - , TypeScript.Syntax.TypeAssertion - , TypeScript.Syntax.ImportAlias - , TypeScript.Syntax.Debugger - , TypeScript.Syntax.ShorthandPropertyIdentifier - , TypeScript.Syntax.Super - , TypeScript.Syntax.Undefined - , TypeScript.Syntax.ClassHeritage - , TypeScript.Syntax.AbstractClass - , TypeScript.Syntax.ImplementsClause - , TypeScript.Syntax.OptionalParameter - , TypeScript.Syntax.RequiredParameter - , TypeScript.Syntax.RestParameter - , TypeScript.Syntax.PropertySignature - , TypeScript.Syntax.AmbientDeclaration - , TypeScript.Syntax.EnumDeclaration - , TypeScript.Syntax.ExtendsClause - , TypeScript.Syntax.AmbientFunction - , TypeScript.Syntax.ImportRequireClause - , TypeScript.Syntax.ImportClause - , TypeScript.Syntax.LabeledStatement - , TypeScript.Syntax.Annotation - , TypeScript.Syntax.With - , TypeScript.Syntax.ForOf - , TypeScript.Syntax.Update - , TypeScript.Syntax.ComputedPropertyName - , TypeScript.Syntax.Decorator - , TypeScript.Syntax.Import - , TypeScript.Syntax.QualifiedAliasedImport - , TypeScript.Syntax.SideEffectImport - , TypeScript.Syntax.DefaultExport - , TypeScript.Syntax.QualifiedExport - , TypeScript.Syntax.QualifiedExportFrom - , TypeScript.Syntax.JavaScriptRequire - , [] - , Statement.StatementBlock - , TypeScript.Syntax.MetaProperty - , TypeScript.Syntax.AnnotatedExpression - ] - - -newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) } - deriving (Eq, Declarations, FreeVariables, Ord, Show) - -instance Term.IsTerm Term where - type Syntax Term = Sum.Sum Syntax - toTermF = coerce - fromTermF = coerce - -instance Foldable Term where - foldMap = foldMapDefault - -instance Functor Term where - fmap = fmapDefault - -instance Traversable Term where - traverse f = go where go = fmap Term . bitraverse f go . getTerm - -instance VertexDeclaration Term where - toVertex info (Term (Term.In ann syntax)) = toVertex1 ann info syntax - -instance Syntax.HasErrors Term where - getErrors = cata $ \ (Term.In Loc{..} syntax) -> - maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax) - - -type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann - -instance Recursive (Term ann) where - project = getTerm - -instance HasSpan ann => HasSpan (Term ann) where - span_ = inner.span_ where inner = lens getTerm (\t i -> t { getTerm = i }) - {-# INLINE span_ #-} diff --git a/src/Parsing/CMark.hs b/src/Parsing/CMark.hs deleted file mode 100644 index 4703d54777..0000000000 --- a/src/Parsing/CMark.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE DataKinds, RecordWildCards, TypeOperators #-} -module Parsing.CMark -( Grammar(..) -, cmarkParser -, toGrammar -) where - -import CMarkGFM -import Data.Array -import qualified Data.AST as A -import Data.Term -import Source.Loc -import qualified Source.Range as Range -import Source.Source (Source) -import qualified Source.Source as Source -import Source.Span hiding (HasSpan (..)) -import TreeSitter.Language (Symbol (..), SymbolType (..)) - -data Grammar - = Document - | ThematicBreak - | Paragraph - | BlockQuote - | HTMLBlock - | CustomBlock - | CodeBlock - | Heading - | List - | Item - | Text - | SoftBreak - | LineBreak - | HTMLInline - | CustomInline - | Code - | Emphasis - | Strong - | Link - | Image - | Strikethrough - | Table - | TableRow - | TableCell - deriving (Bounded, Enum, Eq, Ix, Ord, Show) - -exts :: [CMarkExtension] -exts = [ - extStrikethrough - , extTable - , extAutolink - , extTagfilter - ] - -cmarkParser :: Source -> A.AST (TermF [] NodeType) Grammar -cmarkParser source = toTerm (Source.totalRange source) (Source.totalSpan source) $ commonmarkToNode [ optSourcePos ] exts (Source.toText source) - where toTerm :: Range -> Span -> Node -> A.AST (TermF [] NodeType) Grammar - toTerm within withinSpan (Node position t children) = - let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position - span = maybe withinSpan toSpan position - in termIn (A.Node (toGrammar t) (Loc range span)) (In t (toTerm range span <$> children)) - - toSpan PosInfo{..} = Span (Pos startLine startColumn) (Pos (max startLine endLine) (succ (if endLine <= startLine then max startColumn endColumn else endColumn))) - - lineRanges = sourceLineRangesByLineNumber source - -toGrammar :: NodeType -> Grammar -toGrammar DOCUMENT{} = Document -toGrammar THEMATIC_BREAK{} = ThematicBreak -toGrammar PARAGRAPH{} = Paragraph -toGrammar BLOCK_QUOTE{} = BlockQuote -toGrammar HTML_BLOCK{} = HTMLBlock -toGrammar CUSTOM_BLOCK{} = CustomBlock -toGrammar CODE_BLOCK{} = CodeBlock -toGrammar HEADING{} = Heading -toGrammar LIST{} = List -toGrammar ITEM{} = Item -toGrammar TEXT{} = Text -toGrammar SOFTBREAK{} = SoftBreak -toGrammar LINEBREAK{} = LineBreak -toGrammar HTML_INLINE{} = HTMLInline -toGrammar CUSTOM_INLINE{} = CustomInline -toGrammar CODE{} = Code -toGrammar EMPH{} = Emphasis -toGrammar STRONG{} = Strong -toGrammar LINK{} = Link -toGrammar IMAGE{} = Image -toGrammar STRIKETHROUGH{} = Strikethrough -toGrammar TABLE{} = Table -toGrammar TABLE_ROW{} = TableRow -toGrammar TABLE_CELL{} = TableCell - - -instance Symbol Grammar where - symbolType _ = Regular - - -spanToRangeInLineRanges :: Array Int Range -> Span -> Range -spanToRangeInLineRanges lineRanges Span{..} = Range - (Range.start (lineRanges ! line start) + pred (column start)) - (Range.start (lineRanges ! line end) + pred (column end)) - -sourceLineRangesByLineNumber :: Source -> Array Int Range -sourceLineRangesByLineNumber source = listArray (1, length lineRanges) lineRanges - where lineRanges = Source.lineRanges source diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 23ff057560..fb4d54ce49 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -3,72 +3,49 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} + +-- TODO: Now that a la carte syntax has been removed, this whole abstraction is of perhaps questionable utility + module Parsing.Parser ( Parser(..) -- * Parsers -- $abstract , SomeParser(..) , goParser -, goParserALaCarte -, goParserPrecise , javaParser -, javascriptParserALaCarte -, javascriptParserPrecise , javascriptParser , jsonParser -, jsxParserALaCarte -, jsxParserPrecise , jsxParser , phpParserPrecise -, pythonParserALaCarte -, pythonParserPrecise , pythonParser , codeQLParserPrecise -, rubyParserALaCarte -, rubyParserPrecise , rubyParser -, tsxParserALaCarte -, tsxParserPrecise , tsxParser -, typescriptParserALaCarte -, typescriptParserPrecise , typescriptParser -- * Modes by term type , TermMode -- * Canonical sets of parsers -, aLaCarteParsers , preciseParsers ) where -import Assigning.Assignment import AST.Unmarshal import Data.AST import Data.Language import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.Syntax as Syntax import Foreign.Ptr +import qualified Language.CodeQL as CodeQLPrecise import qualified Language.Go as GoPrecise -import qualified Language.Go.Assignment as GoALaCarte -import Language.Go.Grammar import qualified Language.Java as Java import qualified Language.JSON as JSON import qualified Language.PHP as PHPPrecise import qualified Language.Python as PythonPrecise -import qualified Language.Python.Assignment as PythonALaCarte -import Language.Python.Grammar -import qualified Language.CodeQL as CodeQLPrecise import qualified Language.Ruby as RubyPrecise -import qualified Language.Ruby.Assignment as RubyALaCarte -import Language.Ruby.Grammar (tree_sitter_ruby) import qualified Language.TSX as TSXPrecise -import qualified Language.TSX.Assignment as TSXALaCarte import qualified Language.TypeScript as TypeScriptPrecise -import qualified Language.TypeScript.Assignment as TypeScriptALaCarte -import Language.TypeScript.Grammar import Prelude hiding (fail) -import qualified TreeSitter.Language as TS (Language, Symbol) -import TreeSitter.TSX +import Source.Loc +import qualified TreeSitter.Language as TS (Language) -- | A parser from 'Source' onto some term type. data Parser term where @@ -76,12 +53,6 @@ data Parser term where ASTParser :: (Bounded grammar, Enum grammar, Show grammar) => Ptr TS.Language -> Parser (AST grammar) -- | A parser 'Unmarshal'ing to a precise AST type using a 'TS.Language'. UnmarshalParser :: Unmarshal t => Ptr TS.Language -> Parser (t Loc) - -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. - AssignmentParser :: (TS.Symbol grammar, Syntax.HasErrors term, Foldable term) - => Parser (AST grammar) -- ^ A parser producing AST. - -> Assignment grammar (term Loc) -- ^ An assignment from AST onto 'Term's. - -> Parser (term Loc) -- ^ A parser producing 'Term's. - -- $abstract -- Most of our features are intended to operate over multiple languages, each represented by disjoint term types. Thus, we typically implement them using typeclasses, allowing us to share a single interface to invoke the feature, while specializing the implementation(s) as appropriate for each distinct term type. @@ -114,95 +85,38 @@ data Parser term where data SomeParser c a where SomeParser :: c t => Parser (t a) -> SomeParser c a -goParserALaCarte :: c GoALaCarte.Term => (Language, SomeParser c Loc) -goParserALaCarte = (Go, SomeParser (AssignmentParser (ASTParser tree_sitter_go) GoALaCarte.assignment)) - -goParserPrecise :: c GoPrecise.Term => (Language, SomeParser c Loc) -goParserPrecise = (Go, SomeParser (UnmarshalParser @GoPrecise.Term GoPrecise.tree_sitter_go)) - -goParser :: (c GoALaCarte.Term, c GoPrecise.Term) => PerLanguageModes -> (Language, SomeParser c Loc) -goParser modes = case goMode modes of - ALaCarte -> goParserALaCarte - Precise -> goParserPrecise +goParser :: c GoPrecise.Term => (Language, SomeParser c Loc) +goParser = (Go, SomeParser (UnmarshalParser @GoPrecise.Term GoPrecise.tree_sitter_go)) javaParser :: c Java.Term => (Language, SomeParser c Loc) javaParser = (Java, SomeParser (UnmarshalParser @Java.Term Java.tree_sitter_java)) -javascriptParserALaCarte :: c TSXALaCarte.Term => (Language, SomeParser c Loc) -javascriptParserALaCarte = (JavaScript, SomeParser (AssignmentParser (ASTParser tree_sitter_tsx) TSXALaCarte.assignment)) - -javascriptParserPrecise :: c TSXPrecise.Term => (Language, SomeParser c Loc) -javascriptParserPrecise = (JavaScript, SomeParser (UnmarshalParser @TSXPrecise.Term TSXPrecise.tree_sitter_tsx)) - -javascriptParser :: (c TSXALaCarte.Term, c TSXPrecise.Term) => PerLanguageModes -> (Language, SomeParser c Loc) -javascriptParser modes = case javascriptMode modes of - ALaCarte -> javascriptParserALaCarte - Precise -> javascriptParserPrecise +javascriptParser :: c TSXPrecise.Term => (Language, SomeParser c Loc) +javascriptParser = (JavaScript, SomeParser (UnmarshalParser @TSXPrecise.Term TSXPrecise.tree_sitter_tsx)) jsonParser :: c JSON.Term => (Language, SomeParser c Loc) jsonParser = (JSON, SomeParser (UnmarshalParser @JSON.Term JSON.tree_sitter_json)) -jsxParserALaCarte :: c TSXALaCarte.Term => (Language, SomeParser c Loc) -jsxParserALaCarte = (JSX, SomeParser (AssignmentParser (ASTParser tree_sitter_tsx) TSXALaCarte.assignment)) - -jsxParserPrecise :: c TSXPrecise.Term => (Language, SomeParser c Loc) -jsxParserPrecise = (JSX, SomeParser (UnmarshalParser @TSXPrecise.Term TSXPrecise.tree_sitter_tsx)) - -jsxParser :: (c TSXALaCarte.Term, c TSXPrecise.Term) => PerLanguageModes -> (Language, SomeParser c Loc) -jsxParser modes = case jsxMode modes of - ALaCarte -> jsxParserALaCarte - Precise -> jsxParserPrecise +jsxParser :: c TSXPrecise.Term => (Language, SomeParser c Loc) +jsxParser = (JSX, SomeParser (UnmarshalParser @TSXPrecise.Term TSXPrecise.tree_sitter_tsx)) phpParserPrecise :: c PHPPrecise.Term => (Language, SomeParser c Loc) phpParserPrecise = (PHP, SomeParser (UnmarshalParser @PHPPrecise.Term PHPPrecise.tree_sitter_php)) -pythonParserALaCarte :: c PythonALaCarte.Term => (Language, SomeParser c Loc) -pythonParserALaCarte = (Python, SomeParser (AssignmentParser (ASTParser tree_sitter_python) PythonALaCarte.assignment)) - -pythonParserPrecise :: c PythonPrecise.Term => (Language, SomeParser c Loc) -pythonParserPrecise = (Python, SomeParser (UnmarshalParser @PythonPrecise.Term PythonPrecise.tree_sitter_python)) - -pythonParser :: (c PythonALaCarte.Term, c PythonPrecise.Term) => PerLanguageModes -> (Language, SomeParser c Loc) -pythonParser modes = case pythonMode modes of - ALaCarte -> pythonParserALaCarte - Precise -> pythonParserPrecise +pythonParser :: c PythonPrecise.Term => (Language, SomeParser c Loc) +pythonParser = (Python, SomeParser (UnmarshalParser @PythonPrecise.Term PythonPrecise.tree_sitter_python)) codeQLParserPrecise :: c CodeQLPrecise.Term => (Language, SomeParser c Loc) codeQLParserPrecise = (CodeQL, SomeParser (UnmarshalParser @CodeQLPrecise.Term CodeQLPrecise.tree_sitter_ql)) -rubyParserALaCarte :: c RubyALaCarte.Term => (Language, SomeParser c Loc) -rubyParserALaCarte = (Ruby, SomeParser (AssignmentParser (ASTParser tree_sitter_ruby) RubyALaCarte.assignment)) - -rubyParserPrecise :: c RubyPrecise.Term => (Language, SomeParser c Loc) -rubyParserPrecise = (Ruby, SomeParser (UnmarshalParser @RubyPrecise.Term RubyPrecise.tree_sitter_ruby)) - -rubyParser :: (c RubyALaCarte.Term, c RubyPrecise.Term) => PerLanguageModes -> (Language, SomeParser c Loc) -rubyParser modes = case rubyMode modes of - ALaCarte -> rubyParserALaCarte - Precise -> rubyParserPrecise - -tsxParserALaCarte :: c TSXALaCarte.Term => (Language, SomeParser c Loc) -tsxParserALaCarte = (TSX, SomeParser (AssignmentParser (ASTParser tree_sitter_tsx) TSXALaCarte.assignment)) - -tsxParserPrecise :: c TSXPrecise.Term => (Language, SomeParser c Loc) -tsxParserPrecise = (TSX, SomeParser (UnmarshalParser @TSXPrecise.Term TSXPrecise.tree_sitter_tsx)) - -tsxParser :: (c TSXALaCarte.Term, c TSXPrecise.Term) => PerLanguageModes -> (Language, SomeParser c Loc) -tsxParser modes = case tsxMode modes of - ALaCarte -> tsxParserALaCarte - Precise -> tsxParserPrecise +rubyParser :: c RubyPrecise.Term => (Language, SomeParser c Loc) +rubyParser = (Ruby, SomeParser (UnmarshalParser @RubyPrecise.Term RubyPrecise.tree_sitter_ruby)) -typescriptParserALaCarte :: c TypeScriptALaCarte.Term => (Language, SomeParser c Loc) -typescriptParserALaCarte = (TypeScript, SomeParser (AssignmentParser (ASTParser tree_sitter_typescript) TypeScriptALaCarte.assignment)) - -typescriptParserPrecise :: c TypeScriptPrecise.Term => (Language, SomeParser c Loc) -typescriptParserPrecise = (TypeScript, SomeParser (UnmarshalParser @TypeScriptPrecise.Term TypeScriptPrecise.tree_sitter_typescript)) - -typescriptParser :: (c TypeScriptALaCarte.Term, c TypeScriptPrecise.Term) => PerLanguageModes -> (Language, SomeParser c Loc) -typescriptParser modes = case typescriptMode modes of - ALaCarte -> typescriptParserALaCarte - Precise -> typescriptParserPrecise +tsxParser :: c TSXPrecise.Term => (Language, SomeParser c Loc) +tsxParser = (TSX, SomeParser (UnmarshalParser @TSXPrecise.Term TSXPrecise.tree_sitter_tsx)) +typescriptParser :: c TypeScriptPrecise.Term => (Language, SomeParser c Loc) +typescriptParser = (TypeScript, SomeParser (UnmarshalParser @TypeScriptPrecise.Term TypeScriptPrecise.tree_sitter_typescript)) -- | A type family selecting the language mode for a given term type. type family TermMode term where @@ -217,25 +131,6 @@ type family TermMode term where TermMode TSXPrecise.Term = 'Precise TermMode _ = 'ALaCarte --- | The canonical set of parsers producing à la carte terms. -aLaCarteParsers - :: ( c GoALaCarte.Term - , c PythonALaCarte.Term - , c RubyALaCarte.Term - , c TSXALaCarte.Term - , c TypeScriptALaCarte.Term - ) - => Map Language (SomeParser c Loc) -aLaCarteParsers = Map.fromList - [ javascriptParserALaCarte - , jsxParserALaCarte - , pythonParserALaCarte - , rubyParserALaCarte - , tsxParserALaCarte - , typescriptParserALaCarte - , goParserALaCarte - ] - -- | The canonical set of parsers producing precise terms. preciseParsers :: ( c Java.Term @@ -250,15 +145,15 @@ preciseParsers ) => Map Language (SomeParser c Loc) preciseParsers = Map.fromList - [ goParserPrecise - , javascriptParserPrecise + [ goParser + , javascriptParser , jsonParser - , jsxParserPrecise - , pythonParserPrecise + , jsxParser + , pythonParser , phpParserPrecise , codeQLParserPrecise - , rubyParserPrecise - , tsxParserPrecise - , typescriptParserPrecise + , rubyParser + , tsxParser + , typescriptParser , javaParser ] diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 47a5f3d631..8439a668e3 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -23,12 +23,8 @@ import Control.Monad.IO.Class import Data.Blob import Data.ByteString.Builder import Data.Either -import Data.Functor.Classes -import Data.Functor.Foldable import Data.Language import Data.Map.Strict (Map) -import Data.Quieterm -import Data.Term import qualified Language.CodeQL as CodeQL import qualified Language.Go as Go import qualified Language.JSON as JSON @@ -42,7 +38,6 @@ import Parsing.Parser import Semantic.Config import Semantic.Task import Serializing.Format hiding (JSON) -import qualified Serializing.SExpression as SExpr import qualified Serializing.SExpression.Precise as SExpr.Precise (serializeSExpression) import Source.Loc @@ -107,10 +102,6 @@ instance ShowTermBy 'Precise TSX.Term where instance ShowTermBy 'Precise TypeScript.Term where showTermBy = serialize Show . void . TypeScript.getTerm -instance (Recursive (term Loc), Show1 syntax, Base (term Loc) ~ TermF syntax Loc) => ShowTermBy 'ALaCarte term where - showTermBy = serialize Show . quieterm - - sexprTermParsers :: Map Language (SomeParser SExprTerm Loc) sexprTermParsers = preciseParsers @@ -149,6 +140,3 @@ instance SExprTermBy 'Precise TSX.Term where instance SExprTermBy 'Precise TypeScript.Term where sexprTermBy = SExpr.Precise.serializeSExpression . TypeScript.getTerm - -instance (Recursive (term Loc), SExpr.ToSExpression (Base (term Loc))) => SExprTermBy 'ALaCarte term where - sexprTermBy = SExpr.serializeSExpression ByConstructorName diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index f8a1f9bf80..e7cded228f 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -18,7 +18,7 @@ import Semantic.Task.Files import Semantic.Telemetry import qualified Semantic.Telemetry.Log as Log import Semantic.Version -import Serializing.Format hiding (Options) +import Serializing.Format import System.Exit (die) import qualified System.Path as Path import qualified System.Path.PartClass as Path.PartClass diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs deleted file mode 100644 index c3a9793258..0000000000 --- a/src/Semantic/Graph.hs +++ /dev/null @@ -1,512 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Semantic.Graph -( analysisParsers -, AnalyzeTerm -, runGraph -, runCallGraph -, runImportGraph -, runImportGraphToModules -, runImportGraphToModuleInfos -, GraphType(..) -, Graph -, ControlFlowVertex -, style -, runHeap -, runScopeGraph -, runModuleTable -, parsePackage -, parsePythonPackage -, withTermSpans -, resumingResolutionError -, resumingLoadError -, resumingEvalError -, resumingUnspecialized -, resumingAddressError -, resumingValueError -, resumingHeapError -, resumingScopeError -, resumingTypeError -) where - - -import Prelude hiding (readFile) - -import Analysis.Abstract.Caching.FlowInsensitive -import Analysis.Abstract.Collecting -import Analysis.Abstract.Graph as Graph -import Analysis.File -import Analysis.Project -import Control.Abstract hiding (String) -import Control.Abstract.PythonPackage as PythonPackage -import Control.Carrier.Fresh.Strict -import Control.Carrier.Reader -import Control.Carrier.Resumable.Resume -import Control.Carrier.State.Strict -import Control.Effect.Parse -import Control.Lens.Getter -import Control.Monad -import Data.Abstract.AccessControls.Instances () -import Data.Abstract.Address.Hole as Hole -import Data.Abstract.Address.Monovariant as Monovariant -import Data.Abstract.Address.Precise as Precise -import Data.Abstract.Evaluatable -import Data.Abstract.Heap -import Data.Abstract.Module -import qualified Data.Abstract.ModuleTable as ModuleTable -import Data.Abstract.Package as Package -import Data.Abstract.Value.Abstract as Abstract -import Data.Abstract.Value.Concrete as Concrete (Value, ValueError (..), runValueErrorWith) -import Data.Abstract.Value.Type as Type -import Data.Blob -import Data.Functor.Foldable -import Data.Functor (($>)) -import Data.Graph.Algebraic -import Data.Graph.ControlFlowVertex (VertexDeclaration) -import Data.Language as Language -import Data.List (find, isPrefixOf) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Proxy -import Data.Text (pack, unpack) -import Language.Haskell.HsColour -import Language.Haskell.HsColour.Colourise -import Parsing.Parser -import Semantic.Analysis -import Semantic.Task as Task -import Source.Loc as Loc -import Source.Span -import qualified System.Path as Path -import Text.Show.Pretty (ppShow) - --- TODO: this should be zero-indexed (https://github.com/github/semantic/issues/263) -initialSpan :: Span -initialSpan = point (Pos 1 1) - -data GraphType = ImportGraph | CallGraph - -isPathPrefixOf :: Path.AbsRelDir -> Path.AbsRelFile -> Bool -isPathPrefixOf a b = ra == rb && isPrefixOf a' b' where - (ra, a', _) = Path.splitPath a - (rb, b', _) = Path.splitPath b - --- | Constraints required to analyze a term. -class - ( AccessControls (term Loc) - , Declarations (term Loc) - , Evaluatable (Base (term Loc)) - , FreeVariables (term Loc) - , HasSpan (term Loc) - , Ord (term Loc) - , Recursive (term Loc) - , Show (term Loc) - , VertexDeclaration term - ) => AnalyzeTerm term - -instance - ( AccessControls (term Loc) - , Declarations (term Loc) - , Evaluatable (Base (term Loc)) - , FreeVariables (term Loc) - , HasSpan (term Loc) - , Ord (term Loc) - , Recursive (term Loc) - , Show (term Loc) - , VertexDeclaration term - ) => AnalyzeTerm term - -analysisParsers :: Map Language (SomeParser AnalyzeTerm Loc) -analysisParsers = Map.fromList - [ goParserALaCarte - , javascriptParserALaCarte - , pythonParserALaCarte - , rubyParserALaCarte - , typescriptParserALaCarte - , tsxParserALaCarte - ] - -runGraph :: ( Has Distribute sig m - , Has Parse sig m - , Has Resolution sig m - , Has Trace sig m - , Effect sig - ) - => GraphType - -> Bool - -> Project - -> m (Graph ControlFlowVertex) -runGraph type' includePackages project - | Just (SomeParser parser) <- parserForLanguage analysisParsers (projectLanguage project) - , SomeLanguage (lang :: Proxy lang) <- reifyLanguage (projectLanguage project) = do - package <- if projectLanguage project == Language.Python then - parsePythonPackage parser project - else - fmap snd <$> parsePackage parser project - case type' of - ImportGraph -> runImportGraphToModuleInfos lang package - CallGraph -> do - modules <- topologicalSort <$> runImportGraphToModules lang package - runCallGraph lang includePackages modules package - | otherwise = error $ "Analysis not supported for: " <> show (projectLanguage project) - -data SomeLanguage where - SomeLanguage :: HasPrelude lang => Proxy lang -> SomeLanguage - -reifyLanguage :: Language -> SomeLanguage -reifyLanguage = \case - Go -> SomeLanguage (Proxy @'Go) - JavaScript -> SomeLanguage (Proxy @'JavaScript) - PHP -> SomeLanguage (Proxy @'PHP) - Python -> SomeLanguage (Proxy @'Python) - Ruby -> SomeLanguage (Proxy @'Ruby) - TypeScript -> SomeLanguage (Proxy @'TypeScript) - TSX -> SomeLanguage (Proxy @'TSX) - l -> error $ "HasPrelude not supported for: " <> show l - -runCallGraph :: ( AnalyzeTerm term - , HasPrelude lang - , Has Trace sig m - , Effect sig - ) - => Proxy lang - -> Bool - -> [Module (term Loc)] - -> Package (term Loc) - -> m (Graph ControlFlowVertex) -runCallGraph lang includePackages modules package - = fmap (simplify . fst) - . runEvaluator - . graphing @_ @_ @_ @(Hole (Maybe Name) Monovariant) @Abstract - . runHeap - . runScopeGraph - . caching - . raiseHandler (runFresh 0) - . resumingLoadError - . resumingUnspecialized - . resumingScopeError - . resumingHeapError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . raiseHandler (runReader (packageInfo package)) - . raiseHandler (runReader initialSpan) - . raiseHandler (runState initialSpan) - . raiseHandler (runReader (lowerBound @ControlFlowVertex)) - . providingLiveSet - . runModuleTable - . runModules (ModuleTable.modulePaths (packageModules package)) - $ evaluate lang perModule modules - where perTerm = evalTerm (withTermSpans (^. span_) . graphingTerms . cachingTerms) - perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules $ runDomainEffects perTerm - - -runModuleTable :: Evaluator term address value (ReaderC (ModuleTable (Module (ModuleResult address value))) m) a - -> Evaluator term address value m a -runModuleTable = raiseHandler $ runReader lowerBound - -runImportGraphToModuleInfos :: ( AnalyzeTerm term - , HasPrelude lang - , Has Trace sig m - , Effect sig - ) - => Proxy lang - -> Package (term Loc) - -> m (Graph ControlFlowVertex) -runImportGraphToModuleInfos lang package = runImportGraph lang package allModuleInfos - where allModuleInfos info = vertex (maybe (unknownModuleVertex info) (moduleVertex . moduleInfo) (ModuleTable.lookup (modulePath info) (packageModules package))) - -runImportGraphToModules :: ( AnalyzeTerm term - , HasPrelude lang - , Has Trace sig m - , Effect sig - ) - => Proxy lang - -> Package (term Loc) - -> m (Graph (Module (term Loc))) -runImportGraphToModules lang package = runImportGraph lang package resolveOrLowerBound - where resolveOrLowerBound info = maybe lowerBound vertex (ModuleTable.lookup (modulePath info) (packageModules package)) - -runImportGraph :: ( AnalyzeTerm term - , HasPrelude lang - , Has Trace sig m - , Effect sig - ) - => Proxy lang - -> Package (term Loc) - -> (ModuleInfo -> Graph vertex) - -> m (Graph vertex) -runImportGraph lang package f - = fmap (fst >=> f) - . runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) - . raiseHandler (runState lowerBound) - . runHeap - . raiseHandler (runFresh 0) - . resumingLoadError - . resumingUnspecialized - . resumingScopeError - . resumingHeapError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . resumingValueError - . runModuleTable - . runModules (ModuleTable.modulePaths (packageModules package)) - . raiseHandler (runReader (packageInfo package)) - . raiseHandler (runState initialSpan) - . raiseHandler (runReader initialSpan) - . raiseHandler (runState (lowerBound @(ScopeGraph (Hole (Maybe Name) Precise)))) - . runAllocator - $ evaluate lang (graphingModuleInfo (runDomainEffects (evalTerm id))) (snd <$> ModuleTable.toPairs (packageModules package)) - -runHeap :: Evaluator term address value (StateC (Heap address address value) m) a - -> Evaluator term address value m (Heap address address value, a) -runHeap = raiseHandler (runState lowerBound) - -runScopeGraph :: Ord address - => Evaluator term address value (StateC (ScopeGraph address) m) a - -> Evaluator term address value m (ScopeGraph address, a) -runScopeGraph = raiseHandler (runState lowerBound) - --- | Parse a list of files into a 'Package'. -parsePackage :: (Has Distribute sig m, Has Resolution sig m, Has Parse sig m, Has Trace sig m) - => Parser term -- ^ A parser. - -> Project -- ^ Project to parse into a package. - -> m (Package (Blob, term)) -parsePackage parser project = do - p <- parseModules parser project - resMap <- Task.resolutionMap project - let pkg = Package.fromModules n p resMap - pkg <$ trace ("project: " <> prettyShow (() <$ pkg)) - - where - n = Data.Abstract.Evaluatable.name (projectName project) -- TODO: Confirm this is the right `name`. - --- | Parse all files in a project into 'Module's. -parseModules :: (Has Distribute sig m, Has Parse sig m) => Parser term -> Project -> m [Module (Blob, term)] -parseModules parser p = distributeFor (projectBlobs p) (parseModule p parser) - - --- | Parse a list of packages from a python project. -parsePythonPackage :: forall term sig m . - ( AnalyzeTerm term - , Has Distribute sig m - , Has Parse sig m - , Has Resolution sig m - , Has Trace sig m - , Effect sig - ) - => Parser (term Loc) -- ^ A parser. - -> Project -- ^ Project to parse into a package. - -> m (Package (term Loc)) -parsePythonPackage parser project = do - let runAnalysis = runEvaluator @_ @_ @(Value (term Loc) (Hole (Maybe Name) Precise)) - . raiseHandler (runState PythonPackage.Unknown) - . raiseHandler (runState (lowerBound @(Heap (Hole (Maybe Name) Precise) (Hole (Maybe Name) Precise) (Value (term Loc) (Hole (Maybe Name) Precise))))) - . raiseHandler (runFresh 0) - . resumingLoadError - . resumingUnspecialized - -- . resumingEnvironmentError -- TODO: Fix me. Replace with `resumineScopeGraphError`? - . resumingScopeError - . resumingHeapError - . resumingEvalError - . resumingResolutionError - . resumingAddressError - . resumingValueError - . runModuleTable - . runModules lowerBound - . raiseHandler (runReader (PackageInfo (Data.Abstract.Evaluatable.name "setup") lowerBound)) - . raiseHandler (runState initialSpan) - . raiseHandler (runReader initialSpan) - . raiseHandler (runState (lowerBound @(ScopeGraph (Hole (Maybe Name) Precise)))) - . runAllocator - - strat <- case find (\b -> blobPath b == (projectRootDir project Path. Path.relFile "setup.py")) (projectBlobs project) of - Just setupFile -> do - setupModule <- fmap snd <$> parseModule project parser setupFile - fst <$> runAnalysis (evaluate (Proxy @'Language.Python) (runDomainEffects (runPythonPackaging . evalTerm id)) [ setupModule ]) - Nothing -> pure PythonPackage.Unknown - case strat of - PythonPackage.Unknown -> do - modules <- fmap (fmap snd) <$> parseModules parser project - resMap <- Task.resolutionMap project - pure (Package.fromModules (Data.Abstract.Evaluatable.name (projectName project)) modules resMap) -- TODO: Confirm this is the right `name`. - PythonPackage.Packages dirs -> - packageFromProject project [ blob | dir <- dirs - , blob <- projectBlobs project - , packageDir <- [projectRootDir project Path. Path.relDir (unpack dir) ] - , packageDir `isPathPrefixOf` blobPath blob - ] - PythonPackage.FindPackages excludeDirs -> do - trace "In Graph.FindPackages" - let initFiles = filter (isInit . filePath) (projectFiles project) - isInit = (== Path.relFile "__init__.py") . Path.takeFileName - packageDirs = filter (`notElem` ((projectRootDir project Path.) . Path.relDir . unpack <$> excludeDirs)) (Path.takeDirectory . filePath <$> initFiles) - packageFromProject project [ blob | dir <- packageDirs - , blob <- projectBlobs project - , dir `isPathPrefixOf` blobPath blob - ] - where - packageFromProject project filteredBlobs = do - let p = project { projectBlobs = filteredBlobs } - modules <- fmap (fmap snd) <$> parseModules parser p - resMap <- Task.resolutionMap p - pure (Package.fromModules (Data.Abstract.Evaluatable.name $ projectName p) modules resMap) -- TODO: Confirm this is the right `name`. - -parseModule :: Has Parse sig m - => Project - -> Parser term - -> Blob - -> m (Module (Blob, term)) -parseModule proj parser blob = moduleForBlob (Just (Path.toString $ projectRootDir proj)) blob . (,) blob <$> parse parser blob - -withTermSpans :: ( Has (Reader Span) sig m - , Has (State Span) sig m -- last evaluated child's span - ) - => (term -> Span) - -> Open (term -> Evaluator term address value m a) -withTermSpans getSpan recur term = let - span = getSpan term - updatedSpanAlg = withCurrentSpan span (recur term) - in modifyChildSpan span updatedSpanAlg - -resumingResolutionError :: ( Has Trace sig m - ) - => Evaluator term address value (ResumableC (BaseError ResolutionError) m) a - -> Evaluator term address value m a -resumingResolutionError = runResolutionErrorWith $ \ baseError -> do - traceError "ResolutionError" baseError - case baseErrorException baseError of - NotFoundError nameToResolve _ _ -> maybe (traceError ("NotFileError: resolve path is " ++ show nameToResolve) baseError $> Path.toAbsRel Path.emptyFile) pure $ Path.fileFromFileDir nameToResolve - GoImportError pathToResolve -> pure [Path.absRel pathToResolve] - -resumingLoadError :: ( Has Trace sig m - , AbstractHole value - , AbstractHole address - ) - => Evaluator term address value (ResumableC (BaseError (LoadError address value)) m) a - -> Evaluator term address value m a -resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of - ModuleNotFoundError _ -> pure ((hole, hole), hole)) - -resumingEvalError :: ( Has Fresh sig m - , Has Trace sig m - , Show value - , Show term - , AbstractHole address - , AbstractHole value - ) - => Evaluator term address value (ResumableC (BaseError (EvalError term address value)) m) a - -> Evaluator term address value m a -resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of - AccessControlError{} -> pure hole - ConstructorError{} -> pure hole - DefaultExportError{} -> pure () - DerefError{} -> pure hole - ExportError{} -> pure () - FloatFormatError{} -> pure 0 - IntegerFormatError{} -> pure 0 - NoNameError{} -> gensym - RationalFormatError{} -> pure 0 - ReferenceError{} -> pure hole - ScopedEnvError{} -> pure hole) - -resumingUnspecialized :: ( AbstractHole address - , AbstractHole value - , Has Trace sig m - ) - => Evaluator term address value (ResumableC (BaseError (UnspecializedError address value)) m) a - -> Evaluator term address value m a -resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of - UnspecializedError _ -> pure hole - RefUnspecializedError _ -> pure hole) - -resumingAddressError :: ( AbstractHole value - , Has Trace sig m - , Show address - ) - => Evaluator term address value (ResumableC (BaseError (AddressError address value)) m) a - -> Evaluator term address value m a -resumingAddressError = runAddressErrorWith $ \ baseError -> do - traceError "AddressError" baseError - case baseErrorException baseError of - UnallocatedSlot _ -> pure lowerBound - UninitializedSlot _ -> pure hole - -resumingValueError :: ( Has Trace sig m - , Show address - , Show term - ) - => Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) m) a - -> Evaluator term address (Value term address) m a -resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of - CallError{} -> pure hole - StringError val -> pure (pack (prettyShow val)) - BoolError{} -> pure True - BoundsError{} -> pure hole - IndexError{} -> pure hole - NumericError{} -> pure hole - Numeric2Error{} -> pure hole - ComparisonError{} -> pure hole - BitwiseError{} -> pure hole - Bitwise2Error{} -> pure hole - KeyValueError{} -> pure (hole, hole) - ArrayError{} -> pure lowerBound - ArithmeticError{} -> pure hole) - -resumingHeapError :: ( AbstractHole address - , Has Trace sig m - , Show address - ) - => Evaluator term address value (ResumableC (BaseError (HeapError address)) m) a - -> Evaluator term address value m a -resumingHeapError = runHeapErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of - CurrentFrameError -> pure hole - LookupAddressError _ -> pure hole - -- FIXME: this is clearly bogus - LookupFrameError addr -> pure (Frame addr lowerBound lowerBound) - LookupLinksError _ -> pure mempty - LookupLinkError _ -> pure hole) - -resumingScopeError :: ( Has Trace sig m - , AbstractHole (Slot address) - , AbstractHole (Scope address) - , AbstractHole (Path address) - , AbstractHole (Info address) - , AbstractHole address - ) - => Evaluator term address value (ResumableC (BaseError (ScopeError address)) m) a - -> Evaluator term address value m a -resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of - ScopeError _ _ -> pure hole - ImportReferenceError -> pure hole - LookupScopeError -> pure hole - LookupPathError _ -> pure hole - CurrentScopeError -> pure hole - LookupDeclarationScopeError _ -> pure hole - DeclarationByNameError _ -> pure hole) - -resumingTypeError :: ( Has Trace sig m - , Effect sig - , Alternative m - ) - => Evaluator term address Type (ResumableC (BaseError TypeError) - (StateC TypeMap - m)) a - -> Evaluator term address Type m a -resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseError *> case baseErrorException baseError of - UnificationError l r -> pure l <|> pure r - InfiniteType _ r -> pure r) - -prettyShow :: Show a => a -> String -prettyShow = hscolour TTY defaultColourPrefs False False "" False . ppShow - -traceError :: (Has Trace sig m, Show (exc resume)) => String -> BaseError exc resume -> Evaluator term address value m () -traceError prefix baseError = trace $ prefix <> ": " <> prettyShow baseError diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 67a482f36b..73dff9421b 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -68,7 +68,7 @@ import Semantic.Distribute import Semantic.Resolution import qualified Semantic.Task.Files as Files import Semantic.Telemetry -import Serializing.Format hiding (Options) +import Serializing.Format -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap' type TaskC diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 7365222b89..0b026bfc4c 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -7,9 +7,7 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-exported-signatures -Wno-partial-type-signatures -O0 #-} module Semantic.Util - ( evaluateProject' - , justEvaluating - , mergeErrors + ( mergeErrors , reassociate , parseFile , parseFileQuiet @@ -18,80 +16,20 @@ module Semantic.Util import Prelude hiding (readFile) import Analysis.File -import Analysis.Project -import Control.Abstract -import Control.Carrier.Fresh.Strict -import Control.Carrier.Lift import Control.Carrier.Parse.Simple -import Control.Carrier.Reader import Control.Carrier.Resumable.Either (SomeError (..)) -import Control.Carrier.State.Strict -import Control.Carrier.Trace.Printing +import Control.Effect.Reader import Control.Exception hiding (evaluate) -import Control.Lens.Getter import Control.Monad -import Data.Abstract.Address.Precise as Precise -import Data.Abstract.Evaluatable -import Data.Abstract.Module -import qualified Data.Abstract.ModuleTable as ModuleTable -import Data.Abstract.Package -import Data.Abstract.Value.Concrete as Concrete -import Data.Blob.IO -import Data.Graph.Algebraic (topologicalSort) import qualified Data.Language as Language -import Data.List (uncons) -import Data.Maybe import Data.Sum import Parsing.Parser -import Semantic.Analysis import Semantic.Config -import Semantic.Graph import Semantic.Task -import Source.Span (HasSpan (..), Pos (..), point) +import Source.Span (Pos (..), point) import System.Exit (die) -import System.FilePath.Posix (takeDirectory) import qualified System.Path as Path -justEvaluating :: Evaluator term Precise (Value term Precise) _ result - -> IO ( Heap Precise Precise (Value term Precise), - ( ScopeGraph Precise - , Either (SomeError (Sum _)) result) - ) -justEvaluating - = runM - . runEvaluator - . raiseHandler runTrace - . runHeap - . runScopeGraph - . raiseHandler (fmap snd . runFresh 0) - . fmap reassociate - . runLoadError - . runUnspecialized - . runScopeError - . runHeapError - . runEvalError - . runResolutionError - . runAddressError - . runValueError - --- Evaluate a project consisting of the listed paths. -evaluateProject' session proxy parser paths = do - let lang = Language.reflect proxy - res <- runTask session $ asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout $ do - blobs <- catMaybes <$> traverse readBlobFromFile (fileForPath <$> paths) - package <- fmap snd <$> parsePackage parser (Project (Path.absRel $ takeDirectory (maybe "/" fst (uncons paths))) blobs lang []) - modules <- topologicalSort <$> runImportGraphToModules proxy package - trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules) - pure (package, modules) - (package, modules) <- either (die . displayException) pure res - let initialSpan = point (Pos 1 1) - pure (runModuleTable - (runModules (ModuleTable.modulePaths (packageModules package)) - (raiseHandler (runReader (packageInfo package)) - (raiseHandler (evalState initialSpan) - (raiseHandler (runReader initialSpan) - (evaluate proxy (runDomainEffects (evalTerm (withTermSpans (^. span_)))) modules)))))) - parseFile, parseFileQuiet :: Parser term -> FilePath -> IO term parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath) parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath) diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs index 9568ec5d8c..1a6b10bf57 100644 --- a/src/Serializing/Format.hs +++ b/src/Serializing/Format.hs @@ -6,25 +6,21 @@ module Serializing.Format , FormatStyle(..) , Builder , runSerialize -, Options(..) ) where import Algebra.Graph.Export.Dot import Algebra.Graph.ToGraph import Data.Aeson (ToJSON (..), fromEncoding) import Data.ByteString.Builder -import Data.Functor.Foldable import Data.ProtoLens.Encoding as Proto import Data.ProtoLens.Message (Message) import Language.Haskell.HsColour import Language.Haskell.HsColour.Colourise -import Serializing.SExpression import Text.Show.Pretty data Format input where DOT :: (Ord vertex, ToGraph graph, ToVertex graph ~ vertex) => Style vertex Builder -> Format graph JSON :: ToJSON input => Format input - SExpression :: (Recursive input, ToSExpression (Base input)) => Options -> Format input Show :: Show input => Format input Proto :: Message input => Format input @@ -33,7 +29,6 @@ data FormatStyle = Colourful | Plain runSerialize :: FormatStyle -> Format input -> input -> Builder runSerialize _ (DOT style) = export style runSerialize _ JSON = (<> "\n") . fromEncoding . toEncoding -runSerialize _ (SExpression opts) = serializeSExpression opts runSerialize Colourful Show = (<> "\n") . stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow runSerialize Plain Show = (<> "\n") . stringUtf8 . show runSerialize _ Proto = Proto.buildMessage diff --git a/src/Serializing/SExpression.hs b/src/Serializing/SExpression.hs deleted file mode 100644 index 8faaf5b7af..0000000000 --- a/src/Serializing/SExpression.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Serializing.SExpression -( serializeSExpression -, ToSExpression(..) -, Options(..) -) where - -import Analysis.ConstructorName -import Data.ByteString.Builder -import Data.Functor.Foldable -import Data.Term - -data Options = ByShow | ByConstructorName - -serializeSExpression :: (Recursive t, ToSExpression (Base t)) => Options -> t -> Builder -serializeSExpression options t = cata (toSExpression options) t 0 <> "\n" - -branch :: Foldable syntax => String -> syntax (Int -> Builder) -> Int -> Builder -branch name syntax n = "(" <> stringUtf8 name <> foldMap ($ (n + 1)) syntax <> ")" - -namedBranch :: (ConstructorName syntax, Foldable syntax, Show ann) => Options -> TermF syntax ann (Int -> Builder) -> Int -> Builder -namedBranch ByShow (In ann syntax) = branch (show ann) syntax -namedBranch ByConstructorName (In _ syntax) = branch (constructorName syntax) syntax - -nl :: Int -> Builder -nl n | n <= 0 = "" - | otherwise = "\n" - -pad :: Int -> Builder -pad n = stringUtf8 (replicate (2 * n) ' ') - - -class ToSExpression base where - toSExpression :: Options -> base (Int -> Builder) -> (Int -> Builder) - -instance (ConstructorName syntax, Foldable syntax, Show ann) => ToSExpression (TermF syntax ann) where - toSExpression options term n = nl n <> pad n <> namedBranch options term n diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs deleted file mode 100644 index e9d3e9aee1..0000000000 --- a/test/Analysis/Go/Spec.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DataKinds, ImplicitParams, OverloadedStrings, TypeApplications #-} -{-# OPTIONS_GHC -O0 #-} -module Analysis.Go.Spec (spec) where - -import qualified Data.Language as Language -import qualified Language.Go.Term as Go -import Source.Loc -import SpecHelpers - -spec :: (?session :: TaskSession) => Spec -spec = do - describe "Go" $ do - it "imports and wildcard imports" $ do - (scopeGraph, (heap, res)) <- evaluate ["main.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"] - case moduleLookup "main.go" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupMembers "foo" Import scopeAndFrame heap scopeGraph `shouldBe` Just ["New"] - SpecHelpers.lookupDeclaration "main" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "Bar" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "Rab" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - it "imports with aliases (and side effects only)" $ do - (scopeGraph, (heap, res)) <- evaluate ["main1.go", "foo/foo.go", "bar/bar.go", "bar/rab.go"] - case moduleLookup "main1.go" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "f" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "main" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - -- (lookupDeclaration "f" heap >>= deNamespace heap) `shouldBe` Just ("f", ["New"]) - other -> expectationFailure (show other) - - where - fixtures = "test/fixtures/go/analysis/" - evaluate = evaluateProject @'Language.Go @(Go.Term Loc) ?session Proxy . map (fixtures <>) diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs deleted file mode 100644 index c6ab3ad62e..0000000000 --- a/test/Analysis/PHP/Spec.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE DataKinds, ImplicitParams, OverloadedStrings, TypeApplications #-} -{-# OPTIONS_GHC -O0 #-} -module Analysis.PHP.Spec (spec) where - -import qualified Data.Abstract.Value.Concrete as Value -import qualified Data.Language as Language -import qualified Language.PHP.Term as PHP -import Source.Loc -import SpecHelpers - - -spec :: (?session :: TaskSession) => Spec -spec = do - describe "PHP" $ do - xit "evaluates include and require" $ do - (scopeGraph, (heap, res)) <- evaluate ["main.php", "foo.php", "bar.php"] - case moduleLookup "main.php" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - value `shouldBe` Value.Unit - SpecHelpers.lookupDeclaration "bar" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - xit "evaluates include_once and require_once" $ do - (scopeGraph, (heap, res)) <- evaluate ["main_once.php", "foo.php", "bar.php"] - case moduleLookup "main_once.php" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - value `shouldBe` Value.Unit - SpecHelpers.lookupDeclaration "bar" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - xit "evaluates namespaces" $ do - (scopeGraph, (heap, res)) <- evaluate ["namespaces.php"] - case moduleLookup "namespaces.php" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "Foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "NS1" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - - undefined - -- (derefQName heap ("NS1" :| []) env >>= deNamespace heap) `shouldBe` Just ("NS1", ["Sub1", "b", "c"]) - -- (derefQName heap ("NS1" :| ["Sub1"]) env >>= deNamespace heap) `shouldBe` Just ("Sub1", ["Sub2"]) - -- (derefQName heap ("NS1" :| ["Sub1", "Sub2"]) env >>= deNamespace heap) `shouldBe` Just ("Sub2", ["f"]) - other -> expectationFailure (show other) - - where - fixtures = "test/fixtures/php/analysis/" - evaluate = evaluateProject @'Language.PHP @(PHP.Term Loc) ?session Proxy . map (fixtures <>) diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs deleted file mode 100644 index 71fb3848d1..0000000000 --- a/test/Analysis/Python/Spec.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DataKinds, ImplicitParams, OverloadedStrings, TypeApplications #-} -{-# OPTIONS_GHC -O0 #-} -module Analysis.Python.Spec (spec) where - -import Data.Abstract.Value.Concrete -import qualified Data.Language as Language -import qualified Language.Python.Term as Python -import Source.Loc -import SpecHelpers - - -spec :: (?session :: TaskSession) => Spec -spec = do - describe "Python" $ do - it "imports" $ do - (scopeGraph, (heap, res)) <- evaluate ["main.py", "a.py", "b/__init__.py", "b/c.py"] - case moduleLookup "main.py" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "a" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "b" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - - fromJust (SpecHelpers.lookupMembers "a" Import scopeAndFrame heap scopeGraph) `shouldContain` [ "foo" ] - fromJust (SpecHelpers.lookupMembers "b" Import scopeAndFrame heap scopeGraph) `shouldContain` ["c"] - -- (derefQName heap ("b" :| ["c"]) env >>= deNamespace heap) `shouldBe` Just ("c", ["baz"]) - other -> expectationFailure (show other) - - it "imports with aliases" $ do - (scopeGraph, (heap, res)) <- evaluate ["main1.py", "a.py", "b/__init__.py", "b/c.py"] - case moduleLookup "main1.py" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "b" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "e" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - it "imports using from syntax" $ do - (scopeGraph, (heap, res)) <- evaluate ["main2.py", "a.py", "b/__init__.py", "b/c.py"] - case moduleLookup "main2.py" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "bar" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - - -- TODO: Enable when we constrain edge paths with path predicates - -- () <$ SpecHelpers.lookupDeclaration "baz" heap scopeGraph `shouldBe` Nothing - other -> expectationFailure (show other) - - it "imports with relative syntax" $ do - (scopeGraph, (heap, res)) <- evaluate ["main3.py", "c/__init__.py", "c/utils.py"] - case moduleLookup "main3.py" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "utils" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - -- (lookupDeclaration "utils" heap >>= deNamespace heap) `shouldBe` Just ("utils", ["to_s"]) - other -> expectationFailure (show other) - - it "subclasses" $ do - (scopeGraph, (heap, res)) <- evaluate ["subclass.py"] - case moduleLookup "subclass.py" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - SpecHelpers.lookupDeclaration "Foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "Bar" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupMembers "Bar" Superclass scopeAndFrame heap scopeGraph `shouldBe` Just [ "dang" ] - value `shouldBe` String "\"bar\"" - other -> expectationFailure (show other) - - it "handles multiple inheritance left-to-right" $ do - (scopeGraph, (heap, res)) <- evaluate ["multiple_inheritance.py"] - case moduleLookup "multiple_inheritance.py" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - SpecHelpers.lookupMembers "Baz" Superclass scopeAndFrame heap scopeGraph `shouldBe` Just [ "dang" ] - value `shouldBe` String "\"bar!\"" - other -> expectationFailure (show other) - - where - fixtures = "test/fixtures/python/analysis/" - evaluate = evaluateProject @'Language.Python @(Python.Term Loc) ?session Proxy . map (fixtures <>) diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs deleted file mode 100644 index 63518539b6..0000000000 --- a/test/Analysis/Ruby/Spec.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -O0 #-} -module Analysis.Ruby.Spec (spec) where - -import Control.Abstract (Declaration (..), ScopeError (..)) -import Control.Carrier.Resumable.Either (SomeError (..)) -import Data.Abstract.Evaluatable -import Data.Abstract.Number as Number -import Data.Abstract.Value.Concrete as Value -import qualified Data.Language as Language -import Data.Sum -import qualified Language.Ruby.Term as Ruby -import Source.Loc -import SpecHelpers -import qualified System.Path as Path - - - -spec :: (?session :: TaskSession) => Spec -spec = do - describe "Ruby" $ do - it "evaluates require_relative" $ do - (scopeGraph, (heap, res)) <- evaluate ["main.rb", "foo.rb"] - case moduleLookup "main.rb" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - value `shouldBe` Value.Integer (Number.Integer 1) - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - it "evaluates load" $ do - (scopeGraph, (heap, res)) <- evaluate ["load.rb", "foo.rb"] - case moduleLookup "load.rb" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - value `shouldBe` Value.Integer (Number.Integer 1) - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - it "evaluates load with wrapper" $ do - (_, (_, res)) <- evaluate ["load-wrap.rb", "foo.rb"] - res `shouldBe` Left (SomeError (inject @(BaseError (ScopeError Precise)) (BaseError (ModuleInfo (Path.absRel "load-wrap.rb") "Ruby" mempty) (Span (Pos 3 1) (Pos 3 7)) (LookupPathError (Declaration "foo"))))) - - it "evaluates subclass" $ do - (scopeGraph, (heap, res)) <- evaluate ["subclass.rb"] - case moduleLookup "subclass.rb" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - value `shouldBe` String "\"\"" - SpecHelpers.lookupDeclaration "Bar" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "Foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupMembers "Bar" Superclass scopeAndFrame heap scopeGraph `shouldBe` Just ["baz", "foo", "inspect"] - other -> expectationFailure (show other) - - it "evaluates modules" $ do - (scopeGraph, (heap, res)) <- evaluate ["modules.rb"] - case moduleLookup "modules.rb" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "Bar" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - it "handles break correctly" $ do - (_, (_, res)) <- evaluate ["break.rb"] - case moduleLookup "break.rb" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 3) - other -> expectationFailure (show other) - - it "handles next correctly" $ do - (_, (_, res)) <- evaluate ["next.rb"] - case moduleLookup "next.rb" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 8) - other -> expectationFailure (show other) - - it "calls functions with arguments" $ do - (_, (_, res)) <- evaluate ["call.rb"] - case moduleLookup "call.rb" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 579) - other -> expectationFailure (show other) - - it "evaluates early return statements" $ do - (_, (_, res)) <- evaluate ["early-return.rb"] - case moduleLookup "early-return.rb" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 123) - other -> expectationFailure (show other) - - it "has prelude" $ do - (_, (_, res)) <- evaluate ["preluded.rb"] - case moduleLookup "preluded.rb" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` String "\"\"" - other -> expectationFailure (show other) - - it "evaluates __LINE__" $ do - (_, (_, res)) <- evaluate ["line.rb"] - case moduleLookup "line.rb" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Value.Integer (Number.Integer 4) - other -> expectationFailure (show other) - - it "resolves builtins used in the prelude" $ do - (scopeGraph, (heap, res)) <- evaluate ["puts.rb"] - case moduleLookup "puts.rb" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - value `shouldBe` Unit - SpecHelpers.lookupDeclaration "puts" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - where - fixtures = "test/fixtures/ruby/analysis/" - evaluate = evaluateProject @'Language.Ruby @(Ruby.Term Loc) ?session Proxy . map (fixtures <>) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs deleted file mode 100644 index 85d7d28120..0000000000 --- a/test/Analysis/TypeScript/Spec.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -O0 #-} - -module Analysis.TypeScript.Spec (spec) where - -import Control.Abstract.ScopeGraph hiding (AccessControl (..)) -import Control.Carrier.Resumable.Either (SomeError (..)) -import Data.Abstract.Evaluatable -import qualified Data.Abstract.Heap as Heap -import Data.Abstract.Number as Number -import Data.Abstract.Package (PackageInfo (..)) -import qualified Data.Abstract.ScopeGraph as ScopeGraph (AccessControl (..)) -import Data.Abstract.Value.Concrete as Concrete -import qualified Data.Language as Language -import Data.Scientific (scientific) -import Data.Sum -import Data.Syntax.Statement (StatementBlock (..)) -import Data.Text (pack) -import qualified Language.TypeScript.Term as TypeScript -import Source.Loc -import SpecHelpers -import qualified System.Path as Path - -spec :: (?session :: TaskSession) => Spec -spec = do - describe "TypeScript" $ do - it "qualified export from" $ do - (scopeGraph, (heap, res)) <- evaluate ["main6.ts", "baz.ts", "foo.ts"] - case moduleLookup "main6.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - it "imports with aliased symbols" $ do - (scopeGraph, (heap, res)) <- evaluate ["main.ts", "foo.ts", "foo/b.ts"] - case moduleLookup "main.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "bar" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "quz" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - - other -> expectationFailure (show other) - - it "imports with qualified names" $ do - (scopeGraph, (heap, res)) <- evaluate ["main1.ts", "foo.ts", "a.ts"] - case moduleLookup "main1.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - SpecHelpers.lookupDeclaration "b" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - SpecHelpers.lookupDeclaration "z" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - - lookupMembers "b" Import scopeAndFrame heap scopeGraph `shouldBe` Just [ "baz", "foo" ] - lookupMembers "z" Import scopeAndFrame heap scopeGraph `shouldBe` Just [ "baz", "foo" ] - - SpecHelpers.lookupDeclaration "baz" scopeAndFrame heap scopeGraph `shouldBe` Nothing - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldBe` Nothing - other -> expectationFailure (show other) - - it "stores function declaration in scope graph" $ do - (scopeGraph, (heap, res)) <- evaluate ["a.ts"] - case moduleLookup "a.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - SpecHelpers.lookupDeclaration "baz" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - value `shouldBe` Unit - other -> expectationFailure (show other) - - it "imports functions" $ do - (scopeGraph, (heap, res)) <- evaluate ["main4.ts", "foo.ts"] - case moduleLookup "main4.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - value `shouldBe` String (pack "\"this is the foo function\"") - other -> expectationFailure (show other) - - it "side effect only imports dont expose exports" $ do - (scopeGraph, (heap, res)) <- evaluate ["main3.ts", "a.ts"] - case moduleLookup "main3.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - SpecHelpers.lookupDeclaration "baz" scopeAndFrame heap scopeGraph `shouldBe` Nothing - value `shouldBe` Unit - Heap.heapSize heap `shouldBe` 4 - other -> expectationFailure (show other) - - it "fails exporting symbols not defined in the module" $ do - (_, (_, res)) <- evaluate ["bad-export.ts", "pip.ts", "a.ts", "foo.ts"] - res `shouldBe` Left (SomeError (inject @(BaseError (ScopeError Precise)) (BaseError (ModuleInfo (Path.absRel "bad-export.ts") "TypeScript" mempty) (Span (Pos 2 1) (Pos 2 28)) ImportReferenceError))) - - it "evaluates early return statements" $ do - (scopeGraph, (heap, res)) <- evaluate ["early-return.ts"] - case moduleLookup "early-return.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> - SpecHelpers.lookupDeclaration "foo" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - other -> expectationFailure (show other) - - it "evaluates sequence expressions" $ do - (scopeGraph, (heap, res)) <- evaluate ["sequence-expression.ts"] - case moduleLookup "sequence-expression.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> - SpecHelpers.lookupDeclaration "x" scopeAndFrame heap scopeGraph `shouldBe` Just [ Concrete.Float (Number.Decimal (scientific 3 0)) ] - other -> expectationFailure (show other) - - it "evaluates void expressions" $ do - (_, (_, res)) <- evaluate ["void.ts"] - case moduleLookup "void.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Null - other -> expectationFailure (show other) - - it "evaluates delete" $ do - (scopeGraph, (heap, res)) <- evaluate ["delete.ts"] - case moduleLookup "delete.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, value))) -> do - value `shouldBe` Unit - SpecHelpers.lookupDeclaration "x" scopeAndFrame heap scopeGraph `shouldBe` Nothing - other -> expectationFailure (show other) - - it "evaluates await" $ do - (scopeGraph, (heap, res)) <- evaluate ["await.ts"] - case moduleLookup "await.ts" <$> res of - Right (Just (Module _ (scopeAndFrame, _))) -> do - -- Test that f2 is in the scopegraph and heap. - SpecHelpers.lookupDeclaration "f2" scopeAndFrame heap scopeGraph `shouldSatisfy` isJust - -- Test we can't reference y from outside the function - SpecHelpers.lookupDeclaration "y" scopeAndFrame heap scopeGraph `shouldBe` Nothing - other -> expectationFailure (show other) - - it "evaluates BOr statements" $ do - (_, (_, res)) <- evaluate ["bor.ts"] - case moduleLookup "bor.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer 3) - other -> expectationFailure (show other) - - it "evaluates BAnd statements" $ do - (_, (_, res)) <- evaluate ["band.ts"] - case moduleLookup "band.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer 0) - other -> expectationFailure (show other) - - it "evaluates BXOr statements" $ do - (_, (_, res)) <- evaluate ["bxor.ts"] - case moduleLookup "bxor.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer 3) - other -> expectationFailure (show other) - - it "evaluates LShift statements" $ do - (_, (_, res)) <- evaluate ["lshift.ts"] - case moduleLookup "lshift.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer 4) - other -> expectationFailure (show other) - - it "evaluates RShift statements" $ do - (_, (_, res)) <- evaluate ["rshift.ts"] - case moduleLookup "rshift.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer 0) - other -> expectationFailure (show other) - - it "evaluates Complement statements" $ do - (_, (_, res)) <- evaluate ["complement.ts"] - case moduleLookup "complement.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` Concrete.Integer (Number.Integer (-2)) - other -> expectationFailure (show other) - - it "uniquely tracks public fields for instances" $ do - (_, (_, res)) <- evaluate ["class1.ts", "class2.ts"] - case moduleLookup "class1.ts" <$> res of - Right (Just (Module _ (_, value))) -> value `shouldBe` (Concrete.Float (Number.Decimal 9.0)) - other -> expectationFailure (show other) - - it "member access of private field definition throws AccessControlError" $ do - (_, (_, res)) <- evaluate ["access_control/adder.ts", "access_control/private_field_definition.ts"] - let expected = Left (SomeError (inject @TypeScriptEvalError (BaseError (ModuleInfo (Path.absRel "private_field_definition.ts") "TypeScript" mempty) (Span (Pos 4 1) (Pos 4 6)) (AccessControlError ("foo", ScopeGraph.Public) ("y", ScopeGraph.Private) (Concrete.Float (Decimal 2.0)))))) - res `shouldBe` expected - - it "member access of private static field definition throws AccessControlError" $ do - (_, (_, res)) <- evaluate ["access_control/adder.ts", "access_control/private_static_field_definition.ts"] - let expected = Left (SomeError (inject @TypeScriptEvalError (BaseError (ModuleInfo (Path.absRel "private_static_field_definition.ts" )"TypeScript" mempty) (Span (Pos 3 1) (Pos 3 8)) (AccessControlError ("Adder", ScopeGraph.Public) ("z", ScopeGraph.Private) Unit)))) - res `shouldBe` expected - - it "member access of private methods throws AccessControlError" $ do - (_, (_, res)) <- evaluate ["access_control/adder.ts", "access_control/private_method.ts"] - let expected = Left (SomeError (inject @TypeScriptEvalError (BaseError (ModuleInfo (Path.absRel "private_method.ts" )"TypeScript" mempty) (Span (Pos 4 1) (Pos 4 16)) (AccessControlError ("foo", ScopeGraph.Public) ("private_add", ScopeGraph.Private) (Closure (PackageInfo "access_control" mempty) (ModuleInfo (Path.absRel "adder.ts") "TypeScript" mempty) (Just "private_add") Nothing [] (Right (TypeScript.Term (In (Loc (Range 146 148) (Span (Pos 7 27) (Pos 7 29))) (inject (StatementBlock []))))) (Precise 20) (Precise 18)))))) - res `shouldBe` expected - - where - fixtures = "test/fixtures/typescript/analysis/" - evaluate = evaluateProject @'Language.TypeScript @(TypeScript.Term Loc) ?session Proxy . map (fixtures <>) - -type TypeScriptEvalError = BaseError (EvalError (TypeScript.Term Loc) Precise (Concrete.Value (TypeScript.Term Loc) Precise)) diff --git a/test/Assigning/Assignment/Spec.hs b/test/Assigning/Assignment/Spec.hs deleted file mode 100644 index 09f8d598c5..0000000000 --- a/test/Assigning/Assignment/Spec.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE OverloadedLists, OverloadedStrings #-} -module Assigning.Assignment.Spec (spec) where - -import Assigning.Assignment -import Data.AST -import Data.Bifunctor (first) -import Data.Ix -import Data.Term -import Data.Text as T (Text, length, words) -import Data.Text.Encoding (encodeUtf8) -import GHC.Stack (getCallStack) -import Prelude hiding (words) -import Source.Range -import Source.Source -import Source.Span -import Test.Hspec -import TreeSitter.Language (Symbol (..), SymbolType (..)) - -spec :: Spec -spec = do - describe "Applicative" $ - it "matches in sequence" $ - fst <$> runAssignment "helloworld" ((,) <$> red <*> red) (makeState [node Red 0 5 [], node Red 5 10 []]) - `shouldBe` - Right (Out "hello", Out "world") - - describe "Alternative" $ do - it "attempts multiple alternatives" $ - fst <$> runAssignment "hello" (green <|> red) (makeState [node Red 0 5 []]) - `shouldBe` - Right (Out "hello") - - it "matches repetitions" $ - let s = "colourless green ideas sleep furiously" - w = words s - (_, nodes) = foldl (\ (i, prev) word -> (i + T.length word + 1, prev <> [node Red i (i + T.length word) []])) (0, []) w in - fst <$> runAssignment (fromUTF8 (encodeUtf8 s)) (many red) (makeState nodes) - `shouldBe` - Right (Out <$> w) - - it "matches one-or-more repetitions against one or more input nodes" $ - fst <$> runAssignment "hello" (some red) (makeState [node Red 0 5 []]) - `shouldBe` - Right [Out "hello"] - - describe "distributing through overlapping committed choices" $ do - - it "matches the left alternative" $ - fst <$> runAssignment "(red (green))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 13 [node Green 5 12 []]]) - `shouldBe` - Right (Out "(green)") - - it "matches the right alternative" $ - fst <$> runAssignment "(red (blue))" (symbol Red *> children green <|> symbol Red *> children blue) (makeState [node Red 0 12 [node Blue 5 11 []]]) - `shouldBe` - Right (Out "(blue)") - - it "matches the left alternatives" $ - fst <$> runAssignment "magenta green green" (symbol Magenta *> many green <|> symbol Magenta *> many blue) (makeState [node Magenta 0 7 [], node Green 8 13 [], node Green 14 19 []]) - `shouldBe` - Right [Out "green", Out "green"] - - it "matches the empty list" $ - fst <$> runAssignment "magenta" (symbol Magenta *> (Left <$> many green) <|> symbol Magenta *> (Right <$> many blue)) (makeState [node Magenta 0 7 []]) - `shouldBe` - Right (Left []) - - it "drops anonymous nodes & matches the left alternative" $ - fst <$> runAssignment "magenta green" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Green 8 13 []]) - `shouldBe` - Right (Out "green") - - it "drops anonymous nodes & matches the right alternative" $ - fst <$> runAssignment "magenta blue" (symbol Magenta *> green <|> symbol Magenta *> blue) (makeState [node Magenta 0 7 [], node Blue 8 12 []]) - `shouldBe` - Right (Out "blue") - - it "alternates repetitions, matching the left alternative" $ - fst <$> runAssignment "green green" (many green <|> many blue) (makeState [node Green 0 5 [], node Green 6 11 []]) - `shouldBe` - Right [Out "green", Out "green"] - - it "alternates repetitions, matching at the end of input" $ - fst <$> runAssignment "" (many green <|> many blue) (makeState []) - `shouldBe` - Right [] - - it "distributes through children rules" $ - fst <$> runAssignment "(red (blue))" (children green <|> children blue) (makeState [node Red 0 12 [node Blue 5 11 []]]) - `shouldBe` - Right (Out "(blue)") - - it "matches rules to the left of pure" $ - fst <$> runAssignment "green" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [node Green 0 5 []]) - `shouldBe` - Right (Out "green") - - it "matches pure instead of rules to its right" $ - fst <$> runAssignment "blue" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [node Blue 0 4 []]) - `shouldBe` - Right (Out "other") - - it "matches other nodes with pure" $ - fst <$> runAssignment "red" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState [node Red 0 3 []]) - `shouldBe` - Right (Out "other") - - it "matches at end with pure" $ - fst <$> runAssignment "red" ((green <|> pure (Out "other") <|> blue) <* many source) (makeState []) - `shouldBe` - Right (Out "other") - - describe "symbol" $ do - it "matches nodes with the same symbol" $ - fst <$> runAssignment "hello" red (makeState [node Red 0 5 []]) `shouldBe` Right (Out "hello") - - it "does not advance past the current node" $ - runAssignment "hi" (symbol Red) (makeState [ node Red 0 2 [] ]) `shouldBe` Left (Error (Span (Pos 1 1) (Pos 1 3)) [] (Just (Right Red)) []) - - describe "without catchError" $ do - it "assignment returns unexpected symbol error" $ - runAssignment "A" - red - (makeState [node Green 0 1 []]) - `shouldBe` - Left (Error (Span (Pos 1 1) (Pos 1 2)) [Right Red] (Just (Right Green)) []) - - it "assignment returns unexpected end of input" $ - runAssignment "A" - (symbol Green *> children (some red)) - (makeState [node Green 0 1 []]) - `shouldBe` - Left (Error (Span (Pos 1 1) (Pos 1 1)) [Right Red] Nothing []) - - describe "eof" $ do - it "matches at the end of branches" $ - fst <$> runAssignment "" eof (makeState [] :: State Grammar) `shouldBe` Right () - - it "matches before anonymous nodes at the end of branches" $ - fst <$> runAssignment "magenta" eof (makeState [ node Magenta 0 7 [] ] :: State Grammar) `shouldBe` Right () - - describe "catchError" $ do - it "catches failed committed choices" $ - fst <$> runAssignment "A" - ((symbol Green *> children red) `catchError` \ _ -> OutError <$ location <*> source) - (makeState [node Green 0 1 []]) - `shouldBe` - Right (OutError "A") - - it "doesn’t catch uncommitted choices" $ - fst <$> runAssignment "A" - (red `catchError` \ _ -> OutError <$ location <*> source) - (makeState [node Green 0 1 []]) - `shouldBe` - Left (Error (Span (Pos 1 1) (Pos 1 2)) [Right Red] (Just (Right Green)) []) - - it "doesn’t catch unexpected end of branch" $ - fst <$> runAssignment "" - (red `catchError` \ _ -> OutError <$ location <*> source) - (makeState []) - `shouldBe` - Left (Error (Span (Pos 1 1) (Pos 1 1)) [Right Red] Nothing []) - - it "doesn’t catch exhaustiveness errors" $ - fst <$> runAssignment "AA" - (red `catchError` \ _ -> OutError <$ location <*> source) - (makeState [node Red 0 1 [], node Red 1 2 []]) - `shouldBe` - Left (Error (Span (Pos 1 2) (Pos 1 3)) [] (Just (Right Red)) []) - - it "can error inside the handler" $ - runAssignment "A" - (symbol Green *> children red `catchError` const blue) - (makeState [node Green 0 1 []]) - `shouldBe` - Left (Error (Span (Pos 1 1) (Pos 1 1)) [Right Red] Nothing []) - - describe "many" $ do - it "takes ones and only one zero width repetition" $ - fst <$> runAssignment "PGG" - (symbol Palette *> children ( many (green <|> pure (Out "always")) )) - (makeState [node Palette 0 1 [node Green 1 2 [], node Green 2 3 []]]) - `shouldBe` - Right [Out "G", Out "G", Out "always"] - - describe "source" $ do - it "produces the node’s source" $ - assign "hi" source (node Red 0 2 []) `shouldBe` Right ("hi") - - it "advances past the current node" $ - snd <$> runAssignment "hi" source (makeState [ node Red 0 2 [] ]) - `shouldBe` - Right (State 2 (Pos 1 3) [] [] []) - - describe "children" $ do - it "advances past the current node" $ - snd <$> runAssignment "a" (children (pure (Out ""))) (makeState [node Red 0 1 []]) - `shouldBe` - Right (State 1 (Pos 1 2) [] [] []) - - it "matches if its subrule matches" $ - () <$ runAssignment "a" (children red) (makeState [node Blue 0 1 [node Red 0 1 []]]) - `shouldBe` - Right () - - it "does not match if its subrule does not match" $ - runAssignment "a" (children red) (makeState [node Blue 0 1 [node Green 0 1 []]]) - `shouldBe` - Left (Error (Span (Pos 1 1) (Pos 1 2)) [Right Red] (Just (Right Green)) []) - - it "matches nested children" $ - fst <$> runAssignment "1" - (symbol Red *> children (symbol Green *> children (symbol Blue *> source))) - (makeState [ node Red 0 1 [ node Green 0 1 [ node Blue 0 1 [] ] ] ]) - `shouldBe` - Right "1" - - it "continues after children" $ - fst <$> runAssignment "BC" - (many (symbol Red *> children (symbol Green *> source) - <|> symbol Blue *> source)) - (makeState [ node Red 0 1 [ node Green 0 1 [] ] - , node Blue 1 2 [] ]) - `shouldBe` - Right ["B", "C"] - - it "matches multiple nested children" $ - fst <$> runAssignment "12" - (symbol Red *> children (many (symbol Green *> children (symbol Blue *> source)))) - (makeState [ node Red 0 2 [ node Green 0 1 [ node Blue 0 1 [] ] - , node Green 1 2 [ node Blue 1 2 [] ] ] ]) - `shouldBe` - Right ["1", "2"] - - describe "runAssignment" $ do - it "drops anonymous nodes before matching symbols" $ - fst <$> runAssignment "magenta red" red (makeState [node Magenta 0 7 [], node Red 8 11 []]) - `shouldBe` - Right (Out "red") - - it "drops anonymous nodes after matching to ensure exhaustiveness" $ - stateNodes . snd <$> runAssignment "red magenta" red (makeState [node Red 0 3 [], node Magenta 4 11 []]) - `shouldBe` - Right [] - - it "does not drop anonymous nodes when requested" $ - fst <$> runAssignment "magenta red" ((,) <$> magenta <*> red) (makeState [node Magenta 0 7 [], node Red 8 11 []]) - `shouldBe` - Right (Out "magenta", Out "red") - - it "produces errors with callstacks pointing at the failing assignment" $ - first (fmap fst . getCallStack . errorCallStack) (runAssignment "blue" red (makeState [node Blue 0 4 []])) - `shouldBe` - Left [ "symbol" ] - -node :: symbol -> Int -> Int -> [AST symbol] -> AST symbol -node symbol start end children = Term (Node symbol (Loc (Range start end) (Span (Pos 1 (succ start)) (Pos 1 (succ end)))) `In` children) - -data Grammar = Palette | Red | Green | Blue | Magenta - deriving (Bounded, Enum, Eq, Ix, Ord, Show) - -instance Symbol Grammar where - symbolType Magenta = Anonymous - symbolType _ = Regular - -data Out = Out T.Text | OutError T.Text - deriving (Eq, Show) - -red :: HasCallStack => Assignment Grammar Out -red = Out <$ symbol Red <*> source - -green :: HasCallStack => Assignment Grammar Out -green = Out <$ symbol Green <*> source - -blue :: HasCallStack => Assignment Grammar Out -blue = Out <$ symbol Blue <*> source - -magenta :: HasCallStack => Assignment Grammar Out -magenta = Out <$ symbol Magenta <*> source diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index cf46e9c624..118c3414a3 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -13,19 +13,13 @@ module Data.Functor.Listable , (\/) , addWeight , ofWeight -, ListableSyntax ) where import qualified Analysis.Name as Name -import Data.Abstract.ScopeGraph (AccessControl(..)) import Data.Bifunctor.Join import Data.Edit import qualified Data.Language as Language import Data.List.NonEmpty -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Statement as Statement import Data.Term import Data.Text as T (Text, pack) import Data.Sum @@ -67,27 +61,6 @@ liftCons1 tiers f = mapT f tiers `addWeight` 1 liftCons2 :: [Tier a] -> [Tier b] -> (a -> b -> c) -> [Tier c] liftCons2 tiers1 tiers2 f = mapT (uncurry f) (liftTiers2 tiers1 tiers2) `addWeight` 1 --- | Lifts a ternary constructor to a list of tiers, given lists of tiers for its arguments. --- --- Commonly used in the definition of 'Listable1' and 'Listable2' instances. -liftCons3 :: [Tier a] -> [Tier b] -> [Tier c] -> (a -> b -> c -> d) -> [Tier d] -liftCons3 tiers1 tiers2 tiers3 f = mapT (uncurry3 f) (tiers1 >< tiers2 >< tiers3) `addWeight` 1 - where uncurry3 f (a, (b, c)) = f a b c - --- | Lifts a quaternary constructor to a list of tiers, given lists of tiers for its arguments. --- --- Commonly used in the definition of 'Listable1' and 'Listable2' instances. -liftCons4 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> (a -> b -> c -> d -> e) -> [Tier e] -liftCons4 tiers1 tiers2 tiers3 tiers4 f = mapT (uncurry4 f) (tiers1 >< tiers2 >< tiers3 >< tiers4) `addWeight` 1 - where uncurry4 f (a, (b, (c, d))) = f a b c d - --- | Lifts a senary constructor to a list of tiers, given lists of tiers for its arguments. --- --- Commonly used in the definition of 'Listable1' and 'Listable2' instances. -liftCons6 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier d] -> [Tier e] -> [Tier f] -> (a -> b -> c -> d -> e -> f -> g) -> [Tier g] -liftCons6 tiers1 tiers2 tiers3 tiers4 tiers5 tiers6 f = mapT (uncurry6 f) (tiers1 >< tiers2 >< tiers3 >< tiers4 >< tiers5 >< tiers6) `addWeight` 1 - where uncurry6 g (a, (b, (c, (d, (e, f))))) = g a b c d e f - -- Instances instance Listable1 Maybe where @@ -128,9 +101,6 @@ instance Listable1 f => Listable1 (Term f) where instance (Listable1 f, Listable a) => Listable (Term f a) where tiers = tiers1 -instance Listable AccessControl where - tiers = cons0 Public \/ cons0 Protected \/ cons0 Private - instance Listable2 Edit where liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Compare @@ -148,38 +118,6 @@ instance (Listable1 (Sum fs), Listable a) => Listable (Sum fs a) where tiers = tiers1 -instance Listable1 Comment.Comment where - liftTiers _ = cons1 Comment.Comment - -instance Listable1 Declaration.Function where - liftTiers tiers = liftCons4 (liftTiers tiers) tiers (liftTiers tiers) tiers Declaration.Function - -instance Listable1 Declaration.Method where - liftTiers tiers' = liftCons6 (liftTiers tiers') tiers' tiers' (liftTiers tiers') tiers' tiers Declaration.Method - -instance Listable1 Statement.If where - liftTiers tiers = liftCons3 tiers tiers tiers Statement.If - -instance Listable1 Syntax.Context where - liftTiers tiers = liftCons2 (liftTiers tiers) tiers Syntax.Context - -instance Listable1 Syntax.Empty where - liftTiers _ = cons0 Syntax.Empty - -instance Listable1 Syntax.Identifier where - liftTiers _ = cons1 Syntax.Identifier - -type ListableSyntax = Sum - '[ Comment.Comment - , Declaration.Function - , Declaration.Method - , Statement.If - , Syntax.Context - , Syntax.Empty - , Syntax.Identifier - , [] - ] - instance Listable Name.Name where tiers = cons1 Name.name diff --git a/test/Data/Mergeable.hs b/test/Data/Mergeable.hs deleted file mode 100644 index ec5ed39eba..0000000000 --- a/test/Data/Mergeable.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DefaultSignatures, FlexibleContexts, TypeApplications, TypeOperators, UndecidableInstances #-} -module Data.Mergeable ( Mergeable (..) ) where - -import Control.Applicative -import Data.Functor.Identity -import Data.List.NonEmpty -import Data.Sum -import qualified Data.Syntax as Syntax -import qualified Data.Syntax.Comment as Comment -import qualified Data.Syntax.Declaration as Declaration -import qualified Data.Syntax.Statement as Statement -import GHC.Generics - --- Classes - --- | A 'Mergeable' functor is one which supports pushing itself through an 'Alternative' functor. Note the similarities with 'Traversable' & 'Crosswalk'. --- --- This is a kind of distributive law which produces (at least) the union of the two functors’ shapes; i.e. unlike 'Traversable', an 'empty' value in the inner functor does not produce an 'empty' result, and unlike 'Crosswalk', an 'empty' value in the outer functor does not produce an 'empty' result. --- --- For example, 'Data.Diff' uses 'sequenceAlt' to select one side or the other of a diff node, while correctly handling the fact that some patches don’t have any content for that side. -class Functor t => Mergeable t where - -- | Sequence a 'Mergeable' functor by merging the 'Alternative' values. - sequenceAlt :: Alternative f => t (f a) -> f (t a) - default sequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a) - sequenceAlt = genericSequenceAlt - - --- Instances - -instance Mergeable [] where - sequenceAlt = foldr (\ x -> (((:) <$> x <|> pure id) <*>)) (pure []) - -instance Mergeable NonEmpty where - sequenceAlt (x :|[]) = (:|) <$> x <*> pure [] - sequenceAlt (x1:|x2:xs) = (:|) <$> x1 <*> sequenceAlt (x2 : xs) <|> sequenceAlt (x2:|xs) - -instance Mergeable Maybe where - sequenceAlt = maybe (pure empty) (fmap Just) - -instance Mergeable Identity where - sequenceAlt = fmap Identity . runIdentity - -instance (Apply Functor fs, Apply Mergeable fs) => Mergeable (Sum fs) where - sequenceAlt = apply' @Mergeable (\ reinj t -> reinj <$> sequenceAlt t) - -instance Mergeable Comment.Comment -instance Mergeable Declaration.Function -instance Mergeable Declaration.Method -instance Mergeable Statement.If -instance Mergeable Syntax.Context -instance Mergeable Syntax.Empty -instance Mergeable Syntax.Identifier - - --- Generics - -class GMergeable t where - gsequenceAlt :: Alternative f => t (f a) -> f (t a) - -genericSequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a) -genericSequenceAlt = fmap to1 . gsequenceAlt . from1 - - --- Instances - -instance GMergeable U1 where - gsequenceAlt _ = pure U1 - -instance GMergeable Par1 where - gsequenceAlt (Par1 a) = Par1 <$> a - -instance GMergeable (K1 i c) where - gsequenceAlt (K1 a) = pure (K1 a) - -instance Mergeable f => GMergeable (Rec1 f) where - gsequenceAlt (Rec1 a) = Rec1 <$> sequenceAlt a - -instance GMergeable f => GMergeable (M1 i c f) where - gsequenceAlt (M1 a) = M1 <$> gsequenceAlt a - -instance (GMergeable f, GMergeable g) => GMergeable (f :+: g) where - gsequenceAlt (L1 a) = L1 <$> gsequenceAlt a - gsequenceAlt (R1 a) = R1 <$> gsequenceAlt a - -instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where - gsequenceAlt (a :*: b) = (:*:) <$> gsequenceAlt a <*> gsequenceAlt b diff --git a/test/Data/Term/Spec.hs b/test/Data/Term/Spec.hs deleted file mode 100644 index 547beaf461..0000000000 --- a/test/Data/Term/Spec.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE DataKinds #-} -module Data.Term.Spec (spec) where - -import Data.Functor.Listable -import Data.Term -import Test.Hspec (Spec, describe) -import Test.Hspec.Expectations -import Test.Hspec.LeanCheck - -spec :: Spec -spec = do - describe "Term" $ do - prop "equality is reflexive" $ - \ a -> a `shouldBe` (a :: Term ListableSyntax ()) diff --git a/test/Examples.hs b/test/Examples.hs index 2bb4a66cee..54410a6aff 100644 --- a/test/Examples.hs +++ b/test/Examples.hs @@ -69,12 +69,6 @@ goFileSkips = Path.relPath <$> , "moby/vendor/golang.org/x/text/unicode/norm/tables9.0.0.go" , "moby/vendor/golang.org/x/text/unicode/norm/tables10.0.0.go" - -- Assignment timeouts - , "go/src/cmd/compile/internal/gc/constFold_test.go" - , "go/src/cmd/compile/internal/gc/testdata/arithConst.go" - , "moby/vendor/github.com/docker/swarmkit/api/types.pb.go" - , "moby/vendor/github.com/docker/swarmkit/api/control.pb.go" - -- Parser timeouts , "moby/vendor/github.com/ugorji/go/codec/fast-path.generated.go" @@ -86,9 +80,6 @@ goFileSkips = Path.relPath <$> , "go/src/cmd/vet/testdata/testingpkg/tests_test.go" , "moby/vendor/github.com/beorn7/perks/quantile/stream.go" -- Unhandled identifier character: 'ƒ' - -- A la carte struggles on these - , "src/cmd/go/testdata/src/notest/hello.go" -- a la carte chokes on ParseError - , "go/src/cmd/asm/internal/asm/parse.go" -- a la carte spans are off on line 1124 ] goDirSkips :: [Path.RelDir] @@ -101,12 +92,7 @@ goDirSkips = Path.relDir <$> ] pythonFileSkips :: [Path.RelFile] -pythonFileSkips = Path.relPath <$> - [ - -- Assignment doesn't handle f-strings - "thealgorithms/analysis/compression_analysis/psnr.py" - , "thealgorithms/maths/greater_common_divisor.py" - ] +pythonFileSkips = [] rubySkips :: [Path.RelFile] rubySkips = Path.relFile <$> @@ -137,22 +123,7 @@ tsxSkips = Path.relFile <$> typescriptSkips :: [Path.RelFile] typescriptSkips = Path.relFile <$> - [ - -- Assignment timeouts - "npm/node_modules/request/node_modules/http-signature/node_modules/sshpk/node_modules/tweetnacl/nacl-fast.js" - , "npm/node_modules/cli-table2/test/cell-test.js" - , "npm/node_modules/request/node_modules/har-validator/node_modules/ajv/dist/regenerator.min.js" - , "npm/node_modules/request/node_modules/har-validator/node_modules/ajv/dist/ajv.bundle.js" - , "npm/node_modules/request/node_modules/har-validator/node_modules/ajv/dist/ajv.min.js" - , "npm/node_modules/request/node_modules/har-validator/node_modules/ajv/dist/nodent.min.js" - , "npm/node_modules/bluebird/js/browser/bluebird.js" - , "npm/node_modules/bluebird/js/browser/bluebird.min.js" - , "npm/node_modules/bluebird/js/browser/bluebird.core.js" - , "npm/node_modules/cli-table2/node_modules/lodash/index.js" - , "npm/node_modules/cli-table2/node_modules/lodash/index.js" - - -- Parse errors - , "npm/node_modules/slide/lib/async-map-ordered.js" + [ "npm/node_modules/slide/lib/async-map-ordered.js" ] buildExamples :: TaskSession -> LanguageExample -> Path.RelDir -> IO Tasty.TestTree diff --git a/test/Graphing/Calls/Spec.hs b/test/Graphing/Calls/Spec.hs deleted file mode 100644 index 863201759e..0000000000 --- a/test/Graphing/Calls/Spec.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Graphing.Calls.Spec ( spec ) where - -import Prelude hiding (readFile) -import SpecHelpers - -import Algebra.Graph - -import qualified Analysis.File as File -import Control.Effect.Parse -import Data.Graph.Algebraic (Graph (..), topologicalSort) -import Data.Graph.ControlFlowVertex -import qualified Data.Language as Language -import Semantic.Graph -import qualified System.Path as Path - -callGraphPythonProject :: Path.RelFile -> IO (Semantic.Graph.Graph ControlFlowVertex) -callGraphPythonProject path = runTaskOrDie $ do - let proxy = Proxy @'Language.Python - lang = Language.Python - SomeParser parser <- pure . fromJust $! parserForLanguage analysisParsers Language.Python - blob <- readBlobFromFile' (File.fromPath path) - package <- fmap snd <$> parsePackage parser (Project (Path.toAbsRel (Path.takeDirectory path)) [blob] lang []) - modules <- topologicalSort <$> runImportGraphToModules proxy package - runCallGraph proxy False modules package - -spec :: Spec -spec = describe "call graphing" $ do - - let needs r v = unGraph r `shouldSatisfy` hasVertex v - - it "should work for a simple example" $ do - res <- callGraphPythonProject (Path.relFile "test/fixtures/python/graphing/simple/simple.py") - res `needs` Variable "magnus" "simple.py" (Span (Pos 4 1) (Pos 4 7)) - - it "should evaluate both sides of an if-statement" $ do - res <- callGraphPythonProject (Path.relFile "test/fixtures/python/graphing/conditional/conditional.py") - res `needs` Variable "merle" "conditional.py" (Span (Pos 5 5) (Pos 5 10)) - res `needs` Variable "taako" "conditional.py" (Span (Pos 8 5) (Pos 8 10)) - - it "should continue even when a type error is encountered" $ do - res <- callGraphPythonProject (Path.relFile "test/fixtures/python/graphing/typeerror/typeerror.py") - res `needs` Variable "lup" "typeerror.py" (Span (Pos 5 1) (Pos 5 4)) - - it "should continue when an unbound variable is encountered" $ do - res <- callGraphPythonProject (Path.relFile "test/fixtures/python/graphing/unbound/unbound.py") - res `needs` Variable "lucretia" "unbound.py" (Span (Pos 5 1) (Pos 5 9)) diff --git a/test/Spec.hs b/test/Spec.hs index 36967ed140..1cb8f30961 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,22 +2,11 @@ module Main (allTests, legacySpecs, main, tests) where -import qualified Analysis.Go.Spec -import qualified Analysis.PHP.Spec -import qualified Analysis.Python.Spec -import qualified Analysis.Ruby.Spec -import qualified Analysis.TypeScript.Spec -import qualified Assigning.Assignment.Spec -import qualified Control.Abstract.Evaluator.Spec -import qualified Data.Abstract.Name.Spec -import qualified Data.Abstract.Path.Spec import qualified Data.Functor.Classes.Generic.Spec import qualified Data.Graph.Spec import qualified Data.Language.Spec import qualified Data.Scientific.Spec import qualified Data.Semigroup.App.Spec -import qualified Data.Term.Spec -import qualified Graphing.Calls.Spec import qualified Integration.Spec import qualified Numeric.Spec import qualified Parsing.Spec @@ -57,21 +46,10 @@ allTests = do -- documentation: "hspec and tasty serve similar purposes; consider -- using one or the other.") Instead, create a new TestTree value -- in your spec module and add it to the above 'tests' list. -legacySpecs :: (?session :: TaskSession) => Spec +legacySpecs :: Spec legacySpecs = parallel $ do - describe "Analysis.Go" Analysis.Go.Spec.spec - describe "Analysis.PHP" Analysis.PHP.Spec.spec - describe "Analysis.Python" Analysis.Python.Spec.spec - describe "Analysis.Ruby" Analysis.Ruby.Spec.spec - describe "Analysis.TypeScript" Analysis.TypeScript.Spec.spec - describe "Assigning.Assignment" Assigning.Assignment.Spec.spec - describe "Control.Abstract.Evaluator" Control.Abstract.Evaluator.Spec.spec describe "Data.Graph" Data.Graph.Spec.spec - describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec - describe "Data.Abstract.Name" Data.Abstract.Name.Spec.spec describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec - describe "Data.Term" Data.Term.Spec.spec - describe "Graphing.Calls" Graphing.Calls.Spec.spec describe "Tags.Spec" Tags.Spec.spec describe "Semantic" Semantic.Spec.spec describe "Semantic.IO" Semantic.IO.Spec.spec diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index df7d5f9929..b45c4da6fe 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -10,42 +10,21 @@ module SpecHelpers , runTaskOrDie , runParseWithConfig , TaskSession(..) -, testEvaluating , toList , Config , LogQueue , StatQueue -, lookupDeclaration -, lookupMembers -, EdgeLabel(..) -, TestEvaluatingResult -, TestEvaluatingState -, evaluateProject -, moduleLookup ) where import qualified Analysis.File as File import Analysis.Name as X import Analysis.Project as X -import Control.Abstract import Control.Carrier.Fresh.Strict import Control.Carrier.Lift import Control.Carrier.Parse.Simple import Control.Carrier.Reader as X -import Control.Carrier.Resumable.Either -import Control.Carrier.State.Strict -import qualified Control.Carrier.Trace.Ignoring as Trace.Ignoring import Control.Exception (displayException) import Control.Monad as X -import Data.Abstract.Address.Precise as X -import Data.Abstract.Evaluatable -import Data.Abstract.FreeVariables as X -import qualified Data.Abstract.Heap as Heap -import Data.Abstract.Module as X -import Data.Abstract.ModuleTable as X hiding (lookup) -import qualified Data.Abstract.ModuleTable as ModuleTable -import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Abstract.Value.Concrete (Value (..), ValueError, runValueError) import Data.Blob as X import Data.Blob.IO as X import Data.ByteString as X (ByteString) @@ -61,14 +40,12 @@ import Data.Monoid as X (First (..), Last (..), Monoid (..)) import Data.Proxy as X import Data.Semigroup as X (Semigroup (..)) import Data.Semilattice.Lower as X -import Data.Sum as Sum import Data.Term as X import Data.Traversable as X (for) import Debug.Trace as X (traceM, traceShowM) import Parsing.Parser as X import Semantic.Api hiding (Blob, File) import Semantic.Config (Config (..), optionsLogLevel) -import Semantic.Graph (analysisParsers, runHeap, runScopeGraph) import Semantic.Task as X import Semantic.Telemetry (LogQueue, StatQueue) import Semantic.Util as X @@ -82,7 +59,6 @@ import Test.Hspec as X (Spec, SpecWith, around, context, describe, it, import Test.Hspec.Expectations as X import Test.Hspec.LeanCheck as X import Test.LeanCheck as X -import Unsafe.Coerce (unsafeCoerce) instance Lower X.Span where lowerBound = Source.Span.point (Pos 1 1) @@ -107,95 +83,3 @@ readFilePathPair p1 p2 = readFilePair (File.fromPath p1) (File.fromPath p2) -- Run a Task and call `die` if it returns an Exception. runTaskOrDie :: ParseC TaskC a -> IO a runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } (runParseWithConfig task) >>= either (die . displayException) pure - -type TestEvaluatingC term - = ResumableC (BaseError (AddressError Precise (Val term))) - ( ResumableC (BaseError (ValueError term Precise)) - ( ResumableC (BaseError ResolutionError) - ( ResumableC (BaseError (EvalError term Precise (Val term))) - ( ResumableC (BaseError (HeapError Precise)) - ( ResumableC (BaseError (ScopeError Precise)) - ( ResumableC (BaseError (UnspecializedError Precise (Val term))) - ( ResumableC (BaseError (LoadError Precise (Val term))) - ( StateC (Heap Precise Precise (Val term)) - ( StateC (ScopeGraph Precise) - ( FreshC - ( Trace.Ignoring.TraceC - ( LiftC IO)))))))))))) -type TestEvaluatingErrors term - = '[ BaseError (AddressError Precise (Val term)) - , BaseError (ValueError term Precise) - , BaseError ResolutionError - , BaseError (EvalError term Precise (Val term)) - , BaseError (HeapError Precise) - , BaseError (ScopeError Precise) - , BaseError (UnspecializedError Precise (Val term)) - , BaseError (LoadError Precise (Val term)) - ] -type TestEvaluatingState term a - = ( ScopeGraph Precise - , ( Heap Precise Precise (Val term) - , Either (SomeError (Sum.Sum (TestEvaluatingErrors term))) a - ) - ) -type TestEvaluatingResult term = ModuleTable (Module (ModuleResult Precise (Val term))) -testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingC term) a - -> IO (TestEvaluatingState term a) -testEvaluating - = runM - . Trace.Ignoring.runTrace - . fmap snd - . runFresh 0 - . runEvaluator - . runScopeGraph - . runHeap - . fmap reassociate - . runLoadError - . runUnspecialized - . runScopeError - . runHeapError - . runEvalError - . runResolutionError - . runValueError - . runAddressError - -type Val term = Value term Precise - -evaluateProject :: (HasPrelude lang, SLanguage lang) => TaskSession -> Proxy lang -> [FilePath] -> IO (TestEvaluatingState term (TestEvaluatingResult term)) -evaluateProject session proxy = case parserForLanguage analysisParsers lang of - Just (SomeParser parser) -> unsafeCoerce . testEvaluating <=< evaluateProject' session proxy parser - _ -> error $ "analysis not supported for " <> show lang - where lang = reflect proxy - - -members :: EdgeLabel - -> Heap Precise Precise (Value term Precise) - -> ScopeGraph Precise - -> Value term Precise - -> Maybe [Name] -members edgeLabel heap scopeGraph (Data.Abstract.Value.Concrete.Object frame) = frameNames [ edgeLabel ] heap scopeGraph frame -members edgeLabel heap scopeGraph (Class _ _ frame) = frameNames [ edgeLabel ] heap scopeGraph frame -members _ _ _ _ = Nothing - -frameNames :: [ EdgeLabel ] - -> Heap Precise Precise (Value term Precise) - -> ScopeGraph Precise - -> Precise - -> Maybe [ Name ] -frameNames edge heap scopeGraph frame = do - scopeAddress <- Heap.scopeLookup frame heap - scope <- ScopeGraph.lookupScope scopeAddress scopeGraph - pure (unDeclaration <$> toList (ScopeGraph.declarationNames edge scope scopeGraph)) - -lookupMembers :: Name -> EdgeLabel -> (Precise, Precise) -> Heap Precise Precise (Value term Precise) -> ScopeGraph Precise -> Maybe [ Name ] -lookupMembers name edgeLabel scopeAndFrame heap scopeGraph = - (lookupDeclaration name scopeAndFrame heap scopeGraph >>= members edgeLabel heap scopeGraph . Prelude.head) - -lookupDeclaration :: Name -> (Precise, Precise) -> Heap Precise Precise (Value term Precise) -> ScopeGraph Precise -> Maybe [ Value term Precise ] -lookupDeclaration name (currentScope, currentFrame) heap scopeGraph = do - path <- ScopeGraph.lookupScopePath name currentScope scopeGraph - frameAddress <- Heap.lookupFrameAddress path currentFrame heap - toList <$> Heap.getSlotValue (Slot frameAddress (Heap.pathPosition path)) heap - -moduleLookup :: FilePath -> ModuleTable a -> Maybe a -moduleLookup = ModuleTable.lookup . Path.absRel