github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 00:42:33 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into java-assignment

Browse Source
This commit is contained in:
Ayman Nadeem 2018-05-01 10:57:21 -07:00
commit b1c05d6755
2197 changed files with 5163 additions and 3559 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.ghci
View File

@ -27,7 +27,7 @@ assignmentExample lang = case lang of
"Java" -> mk "java" "java"
"PHP" -> mk "php" "php"
_ -> mk "" ""
where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.file \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util")
where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.blob \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util")
:}
:undef assignment
:def assignment assignmentExample

6
.gitignore vendored
View File

@ -10,14 +10,16 @@ dist-newstyle
.ghc.environment.*
tmp/
bin/
/test/fixtures/*/examples
*.hp
*.prof
*.pyc
test.rb
/test.*
/*.html
.bundle/
.licenses/vendor/gems

9
.gitmodules vendored
View File

@ -1,12 +1,3 @@
[submodule "test/repos/jquery"]
path = test/repos/jquery
url = https://github.com/jquery/jquery
[submodule "test/repos/js-test"]
path = test/repos/js-test
url = https://github.com/rewinfrey/js-test.git
[submodule "test/repos/backbone"]
path = test/repos/backbone
url = https://github.com/jashkenas/backbone
[submodule "vendor/hspec-expectations-pretty-diff"]
path = vendor/hspec-expectations-pretty-diff
url = https://github.com/rewinfrey/hspec-expectations-pretty-diff

22
script/generate-example
View File

@ -35,17 +35,23 @@ generate_example () {
diffFileAB="${fileA%%.*}.diffA-B.txt"
diffFileBA="${fileB%%.*}.diffB-A.txt"
status $parseFileA
"$(dirname "$0")/run" semantic parse --sexpression $fileA > $parseFileA
if [ -e "$fileA" ]; then
status $parseFileA
"$(dirname "$0")/run" semantic parse --sexpression $fileA > $parseFileA
fi
status $parseFileB
"$(dirname "$0")/run" semantic parse --sexpression $fileB > $parseFileB
if [ -e "$fileB" ]; then
status $parseFileB
"$(dirname "$0")/run" semantic parse --sexpression $fileB > $parseFileB
fi
status $diffFileAB
"$(dirname "$0")/run" semantic diff --sexpression $fileA $fileB > $diffFileAB
if [ -e "$fileA" -a -e "$fileB" ]; then
status $diffFileAB
"$(dirname "$0")/run" semantic diff --sexpression $fileA $fileB > $diffFileAB
status $diffFileBA
"$(dirname "$0")/run" semantic diff --sexpression $fileB $fileA > $diffFileBA
status $diffFileBA
"$(dirname "$0")/run" semantic diff --sexpression $fileB $fileA > $diffFileBA
fi
}
if [[ -d $1 ]]; then

20
semantic.cabal
View File

@ -15,16 +15,19 @@ library
hs-source-dirs: src
exposed-modules:
-- Analyses & term annotations
Analysis.Abstract.BadVariables
Analysis.Abstract.BadValues
Analysis.Abstract.BadModuleResolutions
Analysis.Abstract.BadAddresses
, Analysis.Abstract.BadSyntax
, Analysis.Abstract.BadModuleResolutions
, Analysis.Abstract.BadVariables
, Analysis.Abstract.BadValues
, Analysis.Abstract.Caching
, Analysis.Abstract.Collecting
, Analysis.Abstract.Dead
, Analysis.Abstract.Erroring
, Analysis.Abstract.Evaluating
, Analysis.Abstract.ImportGraph
, Analysis.Abstract.Quiet
, Analysis.Abstract.Tracing
, Analysis.Abstract.TypeChecking
, Analysis.CallGraph
, Analysis.ConstructorName
, Analysis.CyclomaticComplexity
@ -43,12 +46,11 @@ library
, Control.Abstract.Value
-- Control flow
, Control.Effect
-- Effects used for program analysis
, Control.Effect.Fresh
-- Datatypes for abstract interpretation
, Data.Abstract.Address
, Data.Abstract.Cache
, Data.Abstract.Configuration
, Data.Abstract.Declarations
, Data.Abstract.Environment
, Data.Abstract.Evaluatable
, Data.Abstract.Exports
@ -71,6 +73,7 @@ library
, Data.Blob
, Data.Diff
, Data.Error
, Data.File
, Data.Functor.Both
, Data.Functor.Classes.Generic
, Data.JSON.Fields
@ -82,6 +85,7 @@ library
, Data.Range
, Data.Record
, Data.Semigroup.App
, Data.Semilattice.Lower
, Data.Scientific.Exts
, Data.Source
, Data.Span
@ -90,6 +94,7 @@ library
, Data.Syntax
, Data.Syntax.Comment
, Data.Syntax.Declaration
, Data.Syntax.Directive
, Data.Syntax.Expression
, Data.Syntax.Literal
, Data.Syntax.Statement
@ -143,6 +148,7 @@ library
, Semantic.CLI
, Semantic.Diff
, Semantic.Distribute
, Semantic.Graph
, Semantic.IO
, Semantic.Log
, Semantic.Parse
@ -165,6 +171,7 @@ library
, cmark-gfm
, containers
, directory
, directory-tree
, effects
, filepath
, free
@ -240,6 +247,7 @@ test-suite test
, Analysis.Ruby.Spec
, Analysis.TypeScript.Spec
, Data.Diff.Spec
, Data.Abstract.Path.Spec
, Data.Functor.Classes.Generic.Spec
, Data.Functor.Listable
, Data.Mergeable.Spec

28
src/Analysis/Abstract/BadAddresses.hs Normal file
View File

@ -0,0 +1,28 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
module Analysis.Abstract.BadAddresses where
import Control.Abstract.Analysis
import Data.Abstract.Address
import Prologue
newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses { runBadAddresses :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadAddresses m)
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
, AbstractHole value
, Monoid (Cell location value)
, Show location
)
=> Interpreter (BadAddresses m) (Resumable (AddressError location value) ': effects) where
type Result (BadAddresses m) (Resumable (AddressError location value) ': effects) result = Result m effects result
interpret
= interpret
. runBadAddresses
. raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("AddressError:" <> show err) *> case err of
UnallocatedAddress _ -> yield mempty
UninitializedAddress _ -> yield hole))

39
src/Analysis/Abstract/BadModuleResolutions.hs
View File

@ -1,32 +1,25 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
module Analysis.Abstract.BadModuleResolutions where
import Control.Abstract.Analysis
import Data.Abstract.Evaluatable
import Analysis.Abstract.Evaluating
import Prologue
newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions { runBadModuleResolutions :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadControl term (m effects) => MonadControl term (BadModuleResolutions m effects)
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadModuleResolutions m effects)
deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadModuleResolutions m effects)
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadModuleResolutions m effects)
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadModuleResolutions m effects)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadModuleResolutions m)
instance ( Effectful m
, Member (Resumable (ResolutionError value)) effects
, Member (State (EvaluatingState location term value)) effects
, Member (State [Name]) effects
, MonadAnalysis location term value (m effects)
, MonadValue location value (BadModuleResolutions m effects)
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
)
=> MonadAnalysis location term value (BadModuleResolutions m effects) where
type Effects location term value (BadModuleResolutions m effects) = State [Name] ': Effects location term value (m effects)
analyzeTerm eval term = resumeException @(ResolutionError value) (liftAnalyze analyzeTerm eval term) (
\yield error -> case error of
(RubyError nameToResolve) -> yield nameToResolve)
analyzeModule = liftAnalyze analyzeModule
=> Interpreter (BadModuleResolutions m) (Resumable (ResolutionError value) ': effects) where
type Result (BadModuleResolutions m) (Resumable (ResolutionError value) ': effects) result = Result m effects result
interpret
= interpret
. runBadModuleResolutions
. raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ResolutionError:" <> show err) *> case err of
NotFoundError nameToResolve _ _ -> yield nameToResolve
GoImportError pathToResolve -> yield [pathToResolve]))

33
src/Analysis/Abstract/BadSyntax.hs Normal file
View File

@ -0,0 +1,33 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
module Analysis.Abstract.BadSyntax
( BadSyntax
) where
import Control.Abstract.Analysis
import Data.Abstract.Evaluatable
import Prologue
-- | An analysis which resumes exceptions instead of failing.
--
-- Use it by composing it onto an analysis:
--
-- > interpret @(BadSyntax (Evaluating term value)) (…)
--
-- Note that exceptions thrown by other analyses may not be caught if 'BadSyntax' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery.
newtype BadSyntax m (effects :: [* -> *]) a = BadSyntax { runBadSyntax :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadSyntax m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadSyntax m)
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
, AbstractHole value
)
=> Interpreter (BadSyntax m) (Resumable (Unspecialized value) ': effects) where
type Result (BadSyntax m) (Resumable (Unspecialized value) ': effects) result = Result m effects result
interpret
= interpret
. runBadSyntax
. raiseHandler (relay pure (\ (Resumable err@(Unspecialized _)) yield -> traceM ("Unspecialized:" <> show err) *> yield hole))

64
src/Analysis/Abstract/BadValues.hs
View File

@ -1,42 +1,38 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.BadValues where
import Control.Abstract.Analysis
import Data.Abstract.Evaluatable
import Analysis.Abstract.Evaluating
import Data.Abstract.Environment as Env
import Prologue
import Data.Abstract.Value (ValueError(..))
import Data.ByteString.Char8 (pack)
import Prologue
newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
newtype BadValues m (effects :: [* -> *]) a = BadValues { runBadValues :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadControl term (m effects) => MonadControl term (BadValues m effects)
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadValues m effects)
deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadValues m effects)
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadValues m effects)
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadValues m effects)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadValues m)
instance ( Effectful m
, Member (Resumable (ValueError location value)) effects
, Member (State (EvaluatingState location term value)) effects
, Member (State [Name]) effects
, MonadAnalysis location term value (m effects)
, MonadValue location value (BadValues m effects)
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
, AbstractHole value
, Show value
)
=> MonadAnalysis location term value (BadValues m effects) where
type Effects location term value (BadValues m effects) = State [Name] ': Effects location term value (m effects)
analyzeTerm eval term = resumeException @(ValueError location value) (liftAnalyze analyzeTerm eval term) (
\yield error -> case error of
(ScopedEnvironmentError _) -> do
env <- getEnv
yield (Env.push env)
(CallError val) -> yield val
(StringError val) -> yield (pack $ show val)
BoolError{} -> yield True
Numeric2Error{} -> unit >>= yield
NamespaceError{} -> getEnv >>= yield
)
analyzeModule = liftAnalyze analyzeModule
=> Interpreter (BadValues m) (Resumable (ValueError location value) ': effects) where
type Result (BadValues m) (Resumable (ValueError location value) ': effects) result = Result m effects result
interpret
= interpret
. runBadValues
. raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ValueError" <> show err) *> case err of
CallError val -> yield val
StringError val -> yield (pack (show val))
BoolError{} -> yield True
BoundsError{} -> yield hole
IndexError{} -> yield hole
NumericError{} -> yield hole
Numeric2Error{} -> yield hole
ComparisonError{} -> yield hole
NamespaceError{} -> lower @m getEnv >>= yield
BitwiseError{} -> yield hole
Bitwise2Error{} -> yield hole
KeyValueError{} -> yield (hole, hole)
ArithmeticError{} -> yield hole))

48
src/Analysis/Abstract/BadVariables.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
module Analysis.Abstract.BadVariables
( BadVariables
) where
@ -8,27 +9,30 @@ import Data.Abstract.Evaluatable
import Prologue
-- An analysis that resumes from evaluation errors and records the list of unresolved free variables.
newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
newtype BadVariables m (effects :: [* -> *]) a = BadVariables { runBadVariables :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects)
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadVariables m effects)
deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadVariables m effects)
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadVariables m effects)
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadVariables m effects)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadVariables m)
instance ( Effectful m
, Member (Resumable (EvalError value)) effects
, Member (State [Name]) effects
, MonadAnalysis location term value (m effects)
, MonadValue location value (BadVariables m effects)
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
, AbstractHole value
, Show value
)
=> MonadAnalysis location term value (BadVariables m effects) where
type Effects location term value (BadVariables m effects) = State [Name] ': Effects location term value (m effects)
analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) (
\yield err -> case err of
(FreeVariableError name) -> raise (modify' (name :)) >> unit >>= yield
(FreeVariablesError names) -> raise (modify' (names <>)) >> yield (last names) )
analyzeModule = liftAnalyze analyzeModule
=> Interpreter (BadVariables m) (Resumable (EvalError value) ': State [Name] ': effects) where
type Result (BadVariables m) (Resumable (EvalError value) ': State [Name] ': effects) result = Result m effects (result, [Name])
interpret
= interpret
. runBadVariables
. raiseHandler
( flip runState []
. relay pure (\ (Resumable err) yield -> traceM ("EvalError" <> show err) *> case err of
EnvironmentLookupError{} -> yield hole
DefaultExportError{} -> yield ()
ExportError{} -> yield ()
IntegerFormatError{} -> yield 0
FloatFormatError{} -> yield 0
RationalFormatError{} -> yield 0
FreeVariableError name -> modify' (name :) *> yield hole
FreeVariablesError names -> modify' (names <>) *> yield (fromMaybeLast "unknown" names)))

84
src/Analysis/Abstract/Caching.hs
View File

@ -1,59 +1,52 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
module Analysis.Abstract.Caching
( Caching
) where
import Control.Abstract.Analysis
import Control.Monad.Effect hiding (interpret)
import Data.Abstract.Address
import Data.Abstract.Cache
import Data.Abstract.Configuration
import Data.Abstract.Heap
import Data.Abstract.Live
import Data.Abstract.Module
import Prologue
-- | The effects necessary for caching analyses.
type CachingEffects location term value effects
= NonDet -- For 'Alternative' and 'gather'.
': Reader (Cache location term value) -- The in-cache used as an oracle while converging on a result.
': State (Cache location term value) -- The out-cache used to record results in each iteration of convergence.
': effects
-- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs.
newtype Caching m (effects :: [* -> *]) a = Caching (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
newtype Caching m (effects :: [* -> *]) a = Caching { runCaching :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects)
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Caching m effects)
deriving instance MonadHeap location value (m effects) => MonadHeap location value (Caching m effects)
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Caching m effects)
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Caching m effects)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m)
-- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons.
class MonadEvaluator location term value m => MonadCaching location term value m where
class MonadEvaluator location term value effects m => MonadCaching location term value effects m where
-- | Look up the set of values for a given configuration in the in-cache.
consultOracle :: Configuration location term value -> m (Set (value, Heap location value))
consultOracle :: Configuration location term value -> m effects (Set (value, Heap location value))
-- | Run an action with the given in-cache.
withOracle :: Cache location term value -> m a -> m a
withOracle :: Cache location term value -> m effects a -> m effects a
-- | Look up the set of values for a given configuration in the out-cache.
lookupCache :: Configuration location term value -> m (Maybe (Set (value, Heap location value)))
lookupCache :: Configuration location term value -> m effects (Maybe (Set (value, Heap location value)))
-- | Run an action, caching its result and 'Heap' under the given configuration.
caching :: Configuration location term value -> Set (value, Heap location value) -> m value -> m value
caching :: Configuration location term value -> Set (value, Heap location value) -> m effects value -> m effects value
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
isolateCache :: m a -> m (Cache location term value)
isolateCache :: m effects a -> m effects (Cache location term value)
instance ( Effectful m
, Members (CachingEffects location term value '[]) effects
, MonadEvaluator location term value (m effects)
, Member (Reader (Cache location term value)) effects
, Member (State (Cache location term value)) effects
, MonadEvaluator location term value effects m
, Ord (Cell location value)
, Ord location
, Ord term
, Ord value
)
=> MonadCaching location term value (Caching m effects) where
=> MonadCaching location term value effects (Caching m) where
consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask)
withOracle cache = raise . local (const cache) . lower
withOracle cache = raiseHandler (local (const cache))
lookupCache configuration = raise (cacheLookup configuration <$> get)
caching configuration values action = do
@ -68,18 +61,18 @@ instance ( Effectful m
instance ( Alternative (m effects)
, Corecursive term
, Effectful m
, Members (CachingEffects location term value '[]) effects
, MonadAnalysis location term value (m effects)
, MonadFresh (m effects)
, Member Fresh effects
, Member NonDet effects
, Member (Reader (Cache location term value)) effects
, Member (Reader (Live location value)) effects
, Member (State (Cache location term value)) effects
, MonadAnalysis location term value effects m
, Ord (Cell location value)
, Ord location
, Ord term
, Ord value
)
=> MonadAnalysis location term value (Caching m effects) where
-- We require the 'CachingEffects' in addition to the underlying analysis’ 'Effects'.
type Effects location term value (Caching m effects) = CachingEffects location term value (Effects location term value (m effects))
=> MonadAnalysis location term value effects (Caching m) where
-- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
analyzeTerm recur e = do
c <- getConfiguration (embedSubterm e)
@ -96,15 +89,18 @@ instance ( Alternative (m effects)
cache <- converge (\ prevCache -> isolateCache $ do
putHeap (configurationHeap c)
-- We need to reset fresh generation so that this invocation converges.
reset 0
reset 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 (raise (gather (const ()) (lower (liftAnalyze analyzeModule recur m))))) mempty
withOracle prevCache (raise (gather (const ()) (lower (liftAnalyze analyzeModule recur m))))) mempty
maybe empty scatter (cacheLookup c cache)
reset :: (Effectful m, Member Fresh effects) => Int -> m effects a -> m effects a
reset start = raiseHandler (interposeState start (const pure) (\ counter Fresh yield -> (yield $! succ counter) counter))
-- | 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
@ -121,5 +117,23 @@ converge f = loop
loop x'
-- | Nondeterministically write each of a collection of stores & return their associated results.
scatter :: (Alternative m, Foldable t, MonadEvaluator location term value m) => t (a, Heap location value) -> m a
scatter :: (Alternative (m effects), Foldable t, MonadEvaluator location term value effects m) => t (a, Heap location value) -> m effects a
scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value)
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
, Ord (Cell location value)
, Ord location
, Ord term
, Ord value
)
=> Interpreter (Caching m) (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) where
type Result (Caching m) (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) result = Result m effects ([result], Cache location term value)
interpret
= interpret
. runCaching
. raiseHandler
( flip runState mempty
. flip runReader mempty
. makeChoiceA @[])

62
src/Analysis/Abstract/Collecting.hs
View File

@ -1,43 +1,31 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
module Analysis.Abstract.Collecting
( Collecting
, Retaining
) where
import Control.Abstract.Analysis
import Data.Abstract.Address
import Data.Abstract.Configuration
import Data.Abstract.Heap
import Data.Abstract.Live
import Prologue
newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
-- | An analysis performing GC after every instruction.
newtype Collecting m (effects :: [* -> *]) a = Collecting { runCollecting :: m effects a }
deriving (Alternative, Applicative, Effectful, Functor, Monad)
deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects)
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Collecting m effects)
deriving instance MonadHeap location value (m effects) => MonadHeap location value (Collecting m effects)
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Collecting m effects)
instance ( Effectful m
, Member (Reader (Live location value)) effects
, MonadEvaluator location term value (m effects)
)
=> MonadEvaluator location term value (Collecting m effects) where
getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Collecting m)
instance ( Effectful m
, Foldable (Cell location)
, Member (Reader (Live location value)) effects
, MonadAnalysis location term value (m effects)
, MonadAnalysis location term value effects m
, Ord location
, ValueRoots location value
)
=> MonadAnalysis location term value (Collecting m effects) where
type Effects location term value (Collecting m effects)
= Reader (Live location value)
': Effects location term value (m effects)
=> MonadAnalysis location term value effects (Collecting m) where
-- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term.
analyzeTerm recur term = do
roots <- askRoots
@ -48,15 +36,6 @@ instance ( Effectful m
analyzeModule = liftAnalyze analyzeModule
-- | Retrieve the local 'Live' set.
askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m effects (Live location value)
askRoots = raise ask
-- | Run a computation with the given 'Live' set added to the local root set.
-- extraRoots :: (Effectful m, Member (Reader (Live location value)) effects, Ord location) => Live location value -> m effects a -> m effects a
-- extraRoots roots = raise . local (<> roots) . lower
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
gc :: ( Ord location
, Foldable (Cell location)
@ -81,3 +60,28 @@ reachable roots heap = go mempty roots
Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of
Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen
_ -> seen)
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
, Ord location
)
=> Interpreter (Collecting m) (Reader (Live location value) ': effects) where
type Result (Collecting m) (Reader (Live location value) ': effects) result = Result m effects result
interpret = interpret . runCollecting . raiseHandler (`runReader` mempty)
-- | An analysis providing a 'Live' set, but never performing GC.
newtype Retaining m (effects :: [* -> *]) a = Retaining { runRetaining :: m effects a }
deriving (Alternative, Applicative, Effectful, Functor, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Retaining m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Retaining m)
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
, Ord location
)
=> Interpreter (Retaining m) (Reader (Live location value) ': effects) where
type Result (Retaining m) (Reader (Live location value) ': effects) result = Result m effects result
interpret = interpret . runRetaining . raiseHandler (`runReader` mempty)

25
src/Analysis/Abstract/Dead.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
module Analysis.Abstract.Dead
( DeadCode
) where
@ -10,14 +11,10 @@ import Data.Set (delete)
import Prologue
-- | An analysis tracking dead (unreachable) code.
newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
newtype DeadCode m (effects :: [* -> *]) a = DeadCode { runDeadCode :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects)
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (DeadCode m effects)
deriving instance MonadHeap location value (m effects) => MonadHeap location value (DeadCode m effects)
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (DeadCode m effects)
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (DeadCode m effects)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m)
-- | A set of “dead” (unreachable) terms.
newtype Dead term = Dead { unDead :: Set term }
@ -42,13 +39,11 @@ instance ( Corecursive term
, Effectful m
, Foldable (Base term)
, Member (State (Dead term)) effects
, MonadAnalysis location term value (m effects)
, MonadAnalysis location term value effects m
, Ord term
, Recursive term
)
=> MonadAnalysis location term value (DeadCode m effects) where
type Effects location term value (DeadCode m effects) = State (Dead term) ': Effects location term value (m effects)
=> MonadAnalysis location term value effects (DeadCode m) where
analyzeTerm recur term = do
revive (embedSubterm term)
liftAnalyze analyzeTerm recur term
@ -56,3 +51,11 @@ instance ( Corecursive term
analyzeModule recur m = do
killAll (subterms (subterm (moduleBody m)))
liftAnalyze analyzeModule recur m
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
, Ord term
)
=> Interpreter (DeadCode m) (State (Dead term) ': effects) where
type Result (DeadCode m) (State (Dead term) ': effects) result = Result m effects (result, Dead term)
interpret = interpret . runDeadCode . raiseHandler (`runState` mempty)

19
src/Analysis/Abstract/Erroring.hs Normal file
View File

@ -0,0 +1,19 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.Erroring
( Erroring
) where
import Control.Abstract.Analysis
import Prologue
-- | An analysis that fails on errors.
newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring { runErroring :: m effects a }
deriving (Alternative, Applicative, Effectful, Functor, Monad)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m)
deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Erroring exc m)
instance Interpreter m effects
=> Interpreter (Erroring exc m) (Resumable exc ': effects) where
type Result (Erroring exc m) (Resumable exc ': effects) result = Result m effects (Either (SomeExc exc) result)
interpret = interpret . runErroring . raiseHandler runError

197
src/Analysis/Abstract/Evaluating.hs
View File

@ -1,162 +1,77 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
module Analysis.Abstract.Evaluating
( Evaluating
, EvaluatingState(..)
) where
import Control.Abstract.Analysis
import Control.Monad.Effect
import Data.Abstract.Address
import Data.Abstract.Configuration
import Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.Exports
import Data.Abstract.Heap
import Data.Abstract.Module
import Data.Abstract.ModuleTable
import Data.Abstract.Origin
import qualified Data.IntMap as IntMap
import Lens.Micro
import Prelude hiding (fail)
import Prologue
import Control.Abstract.Analysis
import qualified Control.Monad.Effect as Eff
import Data.Abstract.Environment
import Data.Abstract.Module
import Data.Abstract.ModuleTable
import Data.Abstract.Origin
import Data.Semilattice.Lower
import Prologue
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
newtype Evaluating location term value effects a = Evaluating (Eff effects a)
newtype Evaluating location term value effects a = Evaluating { runEvaluating :: Eff effects a }
deriving (Applicative, Functor, Effectful, Monad)
deriving instance Member Fail effects => MonadFail (Evaluating location term value effects)
deriving instance Member Fresh effects => MonadFresh (Evaluating location term value effects)
deriving instance Member NonDet effects => Alternative (Evaluating location term value effects)
-- | Effects necessary for evaluating (whether concrete or abstract).
type EvaluatingEffects location term value
= '[ Resumable (EvalError value)
, Resumable (ResolutionError value)
, Resumable (LoadError term value)
, Resumable (ValueError location value)
, Resumable (Unspecialized value)
, Fail -- Failure with an error message
, Fresh -- For allocating new addresses and/or type variables.
, Reader (SomeOrigin term) -- The current term’s origin.
, Reader (ModuleTable [Module term]) -- Cache of unevaluated modules
, Reader (Environment location value) -- Default environment used as a fallback in lookupEnv
, State (EvaluatingState location term value) -- Environment, heap, modules, exports, and jumps.
= '[ EvalClosure term value
, EvalModule term value
, Return value
, LoopControl value
, Fail -- Failure with an error message
, Fresh -- For allocating new addresses and/or type variables.
, Reader (SomeOrigin term) -- The current term’s origin.
, Reader (ModuleTable [Module term]) -- Cache of unevaluated modules
, Reader (Environment location value) -- Default environment used as a fallback in lookupEnv
, State (EvaluatorState location term value) -- Environment, heap, modules, exports, and jumps.
]
data EvaluatingState location term value = EvaluatingState
{ environment :: Environment location value
, heap :: Heap location value
, modules :: ModuleTable (Environment location value, value)
, exports :: Exports location value
, jumps :: IntMap.IntMap term
, origin :: SomeOrigin term
}
deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value, Eq (Base term ())) => Eq (EvaluatingState location term value)
deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value, Ord (Base term ())) => Ord (EvaluatingState location term value)
deriving instance (Show (Cell location value), Show location, Show term, Show value, Show (Base term ())) => Show (EvaluatingState location term value)
instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatingState location term value) where
EvaluatingState e1 h1 m1 x1 j1 o1 <> EvaluatingState e2 h2 m2 x2 j2 o2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2) (o1 <> o2)
instance (Ord location, Semigroup (Cell location value)) => Monoid (EvaluatingState location term value) where
mempty = EvaluatingState mempty mempty mempty mempty mempty mempty
mappend = (<>)
_environment :: Lens' (EvaluatingState location term value) (Environment location value)
_environment = lens environment (\ s e -> s {environment = e})
_heap :: Lens' (EvaluatingState location term value) (Heap location value)
_heap = lens heap (\ s h -> s {heap = h})
_modules :: Lens' (EvaluatingState location term value) (ModuleTable (Environment location value, value))
_modules = lens modules (\ s m -> s {modules = m})
_exports :: Lens' (EvaluatingState location term value) (Exports location value)
_exports = lens exports (\ s e -> s {exports = e})
_jumps :: Lens' (EvaluatingState location term value) (IntMap.IntMap term)
_jumps = lens jumps (\ s j -> s {jumps = j})
_origin :: Lens' (EvaluatingState location term value) (SomeOrigin term)
_origin = lens origin (\ s o -> s {origin = o})
(.=) :: Member (State (EvaluatingState location term value)) effects => ASetter (EvaluatingState location term value) (EvaluatingState location term value) a b -> b -> Evaluating location term value effects ()
lens .= val = raise (modify' (lens .~ val))
view :: Member (State (EvaluatingState location term value)) effects => Getting a (EvaluatingState location term value) a -> Evaluating location term value effects a
view lens = raise (gets (^. lens))
localEvaluatingState :: Member (State (EvaluatingState location term value)) effects => Lens' (EvaluatingState location term value) prj -> (prj -> prj) -> Evaluating location term value effects a -> Evaluating location term value effects a
localEvaluatingState lens f action = do
original <- view lens
lens .= f original
v <- action
v <$ lens .= original
instance Members '[Fail, State (EvaluatingState location term value)] effects => MonadControl term (Evaluating location term value effects) where
label term = do
m <- view _jumps
let i = IntMap.size m
_jumps .= IntMap.insert i term m
pure i
goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure
instance Members '[ State (EvaluatingState location term value)
, Reader (Environment location value)
] effects
=> MonadEnvironment location value (Evaluating location term value effects) where
getEnv = view _environment
putEnv = (_environment .=)
withEnv s = localEvaluatingState _environment (const s)
defaultEnvironment = raise ask
withDefaultEnvironment e = raise . local (const e) . lower
getExports = view _exports
putExports = (_exports .=)
withExports s = localEvaluatingState _exports (const s)
localEnv f a = do
modifyEnv (f . Env.push)
result <- a
result <$ modifyEnv Env.pop
instance Member (State (EvaluatingState location term value)) effects
=> MonadHeap location value (Evaluating location term value effects) where
getHeap = view _heap
putHeap = (_heap .=)
instance Members '[ Reader (ModuleTable [Module term])
, State (EvaluatingState location term value)
, Reader (SomeOrigin term)
, Fail
] effects
=> MonadModuleTable location term value (Evaluating location term value effects) where
getModuleTable = view _modules
putModuleTable = (_modules .=)
askModuleTable = raise ask
localModuleTable f a = raise (local f (lower a))
currentModule = do
o <- raise ask
maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o
instance Members (EvaluatingEffects location term value) effects
=> MonadEvaluator location term value (Evaluating location term value effects) where
getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap
instance ( Member (Reader (Environment location value)) effects
, Member (Reader (ModuleTable [Module term])) effects
, Member (Reader (SomeOrigin term)) effects
, Member (State (EvaluatorState location term value)) effects
)
=> MonadEvaluator location term value effects (Evaluating location term value)
instance ( Corecursive term
, Members (EvaluatingEffects location term value) effects
, Member (Reader (Environment location value)) effects
, Member (Reader (ModuleTable [Module term])) effects
, Member (Reader (SomeOrigin term)) effects
, Member (State (EvaluatorState location term value)) effects
, Recursive term
)
=> MonadAnalysis location term value (Evaluating location term value effects) where
type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value
=> MonadAnalysis location term value effects (Evaluating location term value) where
analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term)
analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m)
instance (AbstractHole value, Show term, Show value) => Interpreter (Evaluating location term value) (EvaluatingEffects location term value) where
type Result (Evaluating location term value) (EvaluatingEffects location term value) result
= ( Either String result
, EvaluatorState location term value)
interpret
= interpret
. runEvaluating
. raiseHandler
( flip runState lowerBound -- State (EvaluatorState location term value)
. flip runReader lowerBound -- Reader (Environment location value)
. flip runReader lowerBound -- Reader (ModuleTable [Module term])
. flip runReader lowerBound -- Reader (SomeOrigin term)
. flip runFresh' 0
. runFail
-- NB: We should never have a 'Return', 'Break', or 'Continue' at this point in execution; the scope being returned from/broken from/continued should have intercepted the effect. This handler will therefore only be invoked if we issue a 'Return', 'Break', or 'Continue' outside of such a scope, and unfortunately if this happens it will handle it by resuming the scope being returned from. While it would be _slightly_ more correct to instead exit with the value being returned, we aren’t able to do that here since 'Interpreter'’s type is parametric in the value being returned—we don’t know that we’re returning a @value@ (because we very well may not be). On the balance, I felt the strange behaviour in error cases is worth the improved behaviour in the common case—we get to lose a layer of 'Either' in the result for each.
-- In general, it’s expected that none of the following effects will remain by the time 'interpret' is called—they should have been handled by local 'interpose's—but if they do, we’ll at least trace.
. Eff.interpret (\ control -> case control of
Break value -> traceM ("Evaluating.interpret: resuming uncaught break with " <> show value) $> value
Continue -> traceM "Evaluating.interpret: resuming uncaught continue with hole" $> hole)
. Eff.interpret (\ (Return value) -> traceM ("Evaluating.interpret: resuming uncaught return with " <> show value) $> value)
. Eff.interpret (\ (EvalModule m) -> traceM ("Evaluating.interpret: resuming uncaught EvalModule of " <> show m <> " with hole") $> hole)
. Eff.interpret (\ (EvalClosure term) -> traceM ("Evaluating.interpret: resuming uncaught EvalClosure of " <> show term <> " with hole") $> hole))
-- TODO: Replace 'traceM's with e.g. 'Telemetry'.

77
src/Analysis/Abstract/ImportGraph.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving,
TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.ImportGraph
( ImportGraph(..)
, renderImportGraph
@ -17,9 +16,13 @@ import Data.Abstract.Located
import Data.Abstract.Module hiding (Module)
import Data.Abstract.Origin hiding (Module, Package)
import Data.Abstract.Package hiding (Package)
import Data.Aeson hiding (Result)
import qualified Data.ByteString.Char8 as BC
import Data.ByteString.Lazy (toStrict)
import Data.Output
import qualified Data.Syntax as Syntax
import Data.Term
import Data.Text.Encoding as T
import Prologue hiding (empty, packageName)
-- | The graph of function variableDefinitions to symbols used in a given program.
@ -50,35 +53,28 @@ style = (defaultStyle vertexName)
edgeAttributes Variable{} Module{} = [ "color" := "blue" ]
edgeAttributes _ _ = []
newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing { runImportGraphing :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects)
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (ImportGraphing m effects)
deriving instance MonadHeap location value (m effects) => MonadHeap location value (ImportGraphing m effects)
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (ImportGraphing m effects)
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (ImportGraphing m effects)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m)
instance ( Effectful m
, Member (Reader (SomeOrigin term)) effects
, Member (Resumable (LoadError term value)) effects
, Member (Resumable (LoadError term)) effects
, Member (State ImportGraph) effects
, Member Syntax.Identifier syntax
, MonadAnalysis (Located location term) term value (m effects)
, MonadAnalysis (Located location term) term value effects m
, term ~ Term (Union syntax) ann
)
=> MonadAnalysis (Located location term) term value (ImportGraphing m effects) where
type Effects (Located location term) term value (ImportGraphing m effects) = State ImportGraph ': Effects (Located location term) term value (m effects)
=> MonadAnalysis (Located location term) term value effects (ImportGraphing m) where
analyzeTerm eval term@(In _ syntax) = do
case prj syntax of
Just (Syntax.Identifier name) -> do
moduleInclusion (Variable (unName name))
variableDefinition name
_ -> pure ()
resumeException
@(LoadError term value)
resume
@(LoadError term)
(liftAnalyze analyzeTerm eval term)
(\yield (LoadError name) -> moduleInclusion (Module (BC.pack name)) >> yield [])
@ -96,10 +92,8 @@ moduleGraph = maybe empty (vertex . Module . BC.pack . modulePath) . withSomeOri
-- | Add an edge from the current package to the passed vertex.
packageInclusion :: forall m location term value effects
. ( Effectful m
, Member (Reader (SomeOrigin term)) effects
, Member (State ImportGraph) effects
, MonadEvaluator location term value (m effects)
. ( Member (State ImportGraph) effects
, MonadEvaluator location term value effects m
)
=> Vertex
-> ImportGraphing m effects ()
@ -109,10 +103,8 @@ packageInclusion v = do
-- | Add an edge from the current module to the passed vertex.
moduleInclusion :: forall m location term value effects
. ( Effectful m
, Member (Reader (SomeOrigin term)) effects
, Member (State ImportGraph) effects
, MonadEvaluator location term value (m effects)
. ( Member (State ImportGraph) effects
, MonadEvaluator location term value effects m
)
=> Vertex
-> ImportGraphing m effects ()
@ -121,10 +113,11 @@ moduleInclusion v = do
appendGraph (moduleGraph @term o `connect` vertex v)
-- | Add an edge from the passed variable name to the module it originated within.
variableDefinition :: ( Effectful m
, Member (State ImportGraph) effects
, MonadEvaluator (Located location term) term value (m effects)
) => Name -> ImportGraphing m effects ()
variableDefinition :: ( Member (State ImportGraph) effects
, MonadEvaluator (Located location term) term value effects m
)
=> Name
-> ImportGraphing m effects ()
variableDefinition name = do
graph <- maybe empty (moduleGraph . origin . unAddress) <$> lookupEnv name
appendGraph (vertex (Variable (unName name)) `connect` graph)
@ -151,3 +144,29 @@ instance Ord ImportGraph where
compare (ImportGraph (G.Overlay _ _)) _ = LT
compare _ (ImportGraph (G.Overlay _ _)) = GT
compare (ImportGraph (G.Connect a1 a2)) (ImportGraph (G.Connect b1 b2)) = (compare `on` ImportGraph) a1 b1 <> (compare `on` ImportGraph) a2 b2
instance Output ImportGraph where
toOutput = toStrict . (<> "\n") . encode
instance ToJSON ImportGraph where
toJSON ImportGraph{..} = object [ "vertices" .= vertices, "edges" .= edges ]
where
vertices = toJSON (G.vertexList unImportGraph)
edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unImportGraph)
instance ToJSON Vertex where
toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ]
vertexToText :: Vertex -> Text
vertexToText = decodeUtf8 . vertexName
vertexToType :: Vertex -> Text
vertexToType Package{} = "package"
vertexToType Module{} = "module"
vertexToType Variable{} = "variable"
instance Interpreter m effects
=> Interpreter (ImportGraphing m) (State ImportGraph ': effects) where
type Result (ImportGraphing m) (State ImportGraph ': effects) result = Result m effects (result, ImportGraph)
interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty)

36
src/Analysis/Abstract/Quiet.hs
View File

@ -1,36 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-}
module Analysis.Abstract.Quiet
( Quietly
) where
import Control.Abstract.Analysis
import Data.Abstract.Evaluatable
import Prologue
-- | An analysis which resumes exceptions instead of failing.
--
-- Use it by composing it onto an analysis:
--
-- > runAnalysis @(Quietly (Evaluating term value)) (…)
--
-- Note that exceptions thrown by other analyses may not be caught if 'Quietly' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery.
newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects)
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Quietly m effects)
deriving instance MonadHeap location value (m effects) => MonadHeap location value (Quietly m effects)
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Quietly m effects)
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Quietly m effects)
instance ( Effectful m
, Member (Resumable (Unspecialized value)) effects
, MonadAnalysis location term value (m effects)
, MonadValue location value (Quietly m effects)
)
=> MonadAnalysis location term value (Quietly m effects) where
type Effects location term value (Quietly m effects) = Effects location term value (m effects)
analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield)
analyzeModule = liftAnalyze analyzeModule

27
src/Analysis/Abstract/Tracing.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint
module Analysis.Abstract.Tracing
( Tracing
) where
@ -6,6 +7,7 @@ module Analysis.Abstract.Tracing
import Control.Abstract.Analysis
import Control.Monad.Effect.Writer
import Data.Abstract.Configuration
import Data.Abstract.Live
import Data.Semigroup.Reducer as Reducer
import Data.Union
import Prologue
@ -13,28 +15,31 @@ import Prologue
-- | Trace analysis.
--
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a)
deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh)
newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing { runTracing :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects)
deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Tracing trace m effects)
deriving instance MonadHeap location value (m effects) => MonadHeap location value (Tracing trace m effects)
deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Tracing trace m effects)
deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Tracing trace m effects)
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m)
instance ( Corecursive term
, Effectful m
, Member (Reader (Live location value)) effects
, Member (Writer (trace (Configuration location term value))) effects
, MonadAnalysis location term value (m effects)
, MonadAnalysis location term value effects m
, Ord location
, Reducer (Configuration location term value) (trace (Configuration location term value))
)
=> MonadAnalysis location term value (Tracing trace m effects) where
type Effects location term value (Tracing trace m effects) = Writer (trace (Configuration location term value)) ': Effects location term value (m effects)
=> MonadAnalysis location term value effects (Tracing trace m) where
analyzeTerm recur term = do
config <- getConfiguration (embedSubterm term)
raise (tell @(trace (Configuration location term value)) (Reducer.unit config))
liftAnalyze analyzeTerm recur term
analyzeModule = liftAnalyze analyzeModule
instance ( Interpreter m effects
, MonadEvaluator location term value effects m
, Monoid (trace (Configuration location term value))
)
=> Interpreter (Tracing trace m) (Writer (trace (Configuration location term value)) ': effects) where
type Result (Tracing trace m) (Writer (trace (Configuration location term value)) ': effects) result = Result m effects (result, trace (Configuration location term value))
interpret = interpret . runTracing . raiseHandler runWriter

28
src/Analysis/Abstract/TypeChecking.hs Normal file
View File

@ -0,0 +1,28 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Analysis.Abstract.TypeChecking
( TypeChecking
) where
import Control.Abstract.Analysis
import Data.Abstract.Type
import Prologue hiding (TypeError)
newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking { runTypeChecking :: m effects a }
deriving (Alternative, Applicative, Functor, Effectful, Monad)
deriving instance MonadEvaluator location term Type effects m => MonadEvaluator location term Type effects (TypeChecking m)
deriving instance MonadAnalysis location term Type effects m => MonadAnalysis location term Type effects (TypeChecking m)
instance Interpreter m effects
=> Interpreter (TypeChecking m) (Resumable TypeError ': effects) where
type Result (TypeChecking m) (Resumable TypeError ': effects) result = Result m effects (Either (SomeExc TypeError) result)
interpret
= interpret
. runTypeChecking
-- TODO: We should handle TypeError by yielding both sides of the exception,
-- but something is mysteriously busted in the innards of typechecking,
-- so doing that just yields an empty list in the result type, which isn't
-- extraordinarily helpful. Better for now to just die with an error and
-- tackle this issue in a separate PR.
. raiseHandler runError

20
src/Assigning/Assignment.hs
View File

@ -77,6 +77,8 @@ module Assigning.Assignment
, while
, until
, manyThrough
, getRubyLocals
, putRubyLocals
-- Results
, Error(..)
, errorCallStack
@ -121,6 +123,8 @@ data AssignmentF ast grammar a where
Alt :: [a] -> AssignmentF ast grammar a
Label :: Assignment ast grammar a -> String -> AssignmentF ast grammar a
Fail :: String -> AssignmentF ast grammar a
GetRubyLocals :: AssignmentF ast grammar [ByteString]
PutRubyLocals :: [ByteString] -> AssignmentF ast grammar ()
data Tracing f a where
Tracing :: { tracingCallSite :: Maybe (String, SrcLoc), runTracing :: f a } -> Tracing f a
@ -140,6 +144,13 @@ tracing f = case getCallStack callStack of
location :: HasCallStack => Assignment ast grammar (Record Location)
location = tracing Location `Then` return
getRubyLocals :: HasCallStack => Assignment ast grammar [ByteString]
getRubyLocals = tracing GetRubyLocals `Then` return
putRubyLocals :: (HasCallStack, Enum grammar, Eq1 ast, Ix grammar) => [ByteString] -> Assignment ast grammar ()
putRubyLocals l = (tracing (PutRubyLocals l) `Then` return)
<|> (tracing End `Then` return)
-- | Zero-width production of the current node.
currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar) ())
currentNode = tracing CurrentNode `Then` return
@ -239,6 +250,8 @@ runAssignment source = \ assignment state -> go assignment state >>= requireExha
run yield t initialState = state `seq` maybe (anywhere Nothing) atNode (listToMaybe stateNodes)
where atNode (Term (In node f)) = case runTracing t of
Location -> yield (nodeLocation node) state
GetRubyLocals -> yield stateRubyLocals state
PutRubyLocals l -> yield () (state { stateRubyLocals = l })
CurrentNode -> yield (In node (() <$ f)) state
Source -> yield (Source.sourceBytes (Source.slice (nodeByteRange node) source)) (advanceState state)
Children child -> do
@ -277,7 +290,7 @@ skipTokens state = state { stateNodes = dropWhile ((/= Regular) . symbolType . n
-- | 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 ast grammar -> State ast grammar
advanceState state@State{..}
| Term (In Node{..} _) : rest <- stateNodes = State (end nodeByteRange) (spanEnd nodeSpan) stateCallSites rest
| Term (In Node{..} _) : rest <- stateNodes = State (end nodeByteRange) (spanEnd nodeSpan) stateCallSites rest stateRubyLocals
| otherwise = state
-- | State kept while running 'Assignment's.
@ -286,13 +299,14 @@ data State ast grammar = State
, 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 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.”
, stateRubyLocals :: ![ByteString] -- Special state necessary for the Ruby assignment. When we refactor Assignment to use effects we should pull this out into Language.Ruby.Assignment
}
deriving instance (Eq grammar, Eq1 ast) => Eq (State ast grammar)
deriving instance (Show grammar, Show1 ast) => Show (State ast grammar)
makeState :: [AST ast grammar] -> State ast grammar
makeState = State 0 (Pos 1 1) []
makeState ns = State 0 (Pos 1 1) [] ns []
-- Instances
@ -374,6 +388,8 @@ instance (Enum grammar, Ix grammar, Show grammar, Show1 ast) => Show1 (Assignmen
Alt as -> showsUnaryWith (const sl) "Alt" d (toList as)
Label child string -> showsBinaryWith (liftShowsPrec sp sl) showsPrec "Label" d child string
Fail s -> showsUnaryWith showsPrec "Fail" d s
GetRubyLocals -> showString "GetRubyLocals"
PutRubyLocals _ -> showString "PutRubyLocals _"
where showChild = liftShowsPrec sp sl
showChildren = liftShowList sp sl

75
src/Control/Abstract/Addressable.hs
View File

@ -1,39 +1,39 @@
{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE GADTs, UndecidableInstances #-}
module Control.Abstract.Addressable where
import Control.Abstract.Evaluator
import Control.Applicative
import Control.Effect.Fresh
import Control.Effect
import Control.Monad.Effect.Fresh
import Control.Monad.Effect.Resumable as Eff
import Data.Abstract.Address
import Data.Abstract.Environment (insert)
import Data.Abstract.FreeVariables
import Data.Semigroup.Reducer
import Prelude hiding (fail)
import Prologue
-- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap.
class (MonadFresh m, Ord location) => MonadAddressable location m where
derefCell :: Address location value -> Cell location value -> m value
class (Effectful m, Member Fresh effects, Monad (m effects), Ord location) => MonadAddressable location effects m where
derefCell :: Address location value -> Cell location value -> m effects (Maybe value)
allocLoc :: Name -> m location
allocLoc :: Name -> m effects location
-- | Look up or allocate an address for a 'Name'.
lookupOrAlloc :: ( MonadAddressable location m
, MonadEnvironment location value m
lookupOrAlloc :: ( MonadAddressable location effects m
, MonadEvaluator location term value effects m
)
=> Name
-> m (Address location value)
-> m effects (Address location value)
lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
letrec :: ( MonadAddressable location m
, MonadEnvironment location value m
, MonadHeap location value m
letrec :: ( MonadAddressable location effects m
, MonadEvaluator location term value effects m
, Reducer value (Cell location value)
)
=> Name
-> m value
-> m (value, Address location value)
-> m effects value
-> m effects (value, Address location value)
letrec name body = do
addr <- lookupOrAlloc name
v <- localEnv (insert name addr) body
@ -41,12 +41,12 @@ letrec name body = do
pure (v, addr)
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
letrec' :: ( MonadAddressable location m
, MonadEnvironment location value m
letrec' :: ( MonadAddressable location effects m
, MonadEvaluator location term value effects m
)
=> Name
-> (Address location value -> m value)
-> m value
-> (Address location value -> m effects value)
-> m effects value
letrec' name body = do
addr <- lookupOrAlloc name
v <- localEnv id (body addr)
@ -55,22 +55,39 @@ letrec' name body = do
-- Instances
-- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
instance (MonadFail m, MonadFresh m) => MonadAddressable Precise m where
derefCell addr = maybeM (uninitializedAddress addr) . unLatest
allocLoc _ = Precise <$> fresh
instance (Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Precise effects m where
derefCell _ = pure . unLatest
allocLoc _ = Precise <$> raise fresh
-- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
instance (Alternative m, MonadFresh m) => MonadAddressable Monovariant m where
derefCell _ = foldMapA pure
instance (Alternative (m effects), Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Monovariant effects m where
derefCell _ cell | null cell = pure Nothing
| otherwise = Just <$> foldMapA pure cell
allocLoc = pure . Monovariant
-- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
deref :: (MonadFail m, MonadAddressable location m, MonadHeap location value m, Show location) => Address location value -> m value
deref addr = lookupHeap addr >>= maybe (uninitializedAddress addr) (derefCell addr)
deref :: (Member (Resumable (AddressError location value)) effects, MonadAddressable location effects m, MonadEvaluator location term value effects m) => Address location value -> m effects value
deref addr = do
cell <- lookupHeap addr >>= maybeM (throwAddressError (UnallocatedAddress addr))
derefed <- derefCell addr cell
maybeM (throwAddressError (UninitializedAddress addr)) derefed
alloc :: MonadAddressable location m => Name -> m (Address location value)
alloc :: MonadAddressable location effects m => Name -> m effects (Address location value)
alloc = fmap Address . allocLoc
-- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced).
uninitializedAddress :: (MonadFail m, Show location) => Address location value -> m a
uninitializedAddress addr = fail $ "uninitialized address: " <> show addr
data AddressError location value resume where
UnallocatedAddress :: Address location value -> AddressError location value (Cell location value)
UninitializedAddress :: Address location value -> AddressError location value value
deriving instance Eq location => Eq (AddressError location value resume)
deriving instance Show location => Show (AddressError location value resume)
instance Show location => Show1 (AddressError location value) where
liftShowsPrec _ _ = showsPrec
instance Eq location => Eq1 (AddressError location value) where
liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b
liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b
liftEq _ _ _ = False
throwAddressError :: (Effectful m, Member (Resumable (AddressError location value)) effects) => AddressError location value resume -> m effects resume
throwAddressError = raise . Eff.throwError

56
src/Control/Abstract/Analysis.hs
View File

@ -1,22 +1,17 @@
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis
{-# LANGUAGE KindSignatures #-}
module Control.Abstract.Analysis
( MonadAnalysis(..)
, liftAnalyze
, runAnalysis
, SomeAnalysis(..)
, runSomeAnalysis
, module X
, Subterm(..)
, SubtermAlgebra
) where
import Control.Abstract.Addressable as X
import Control.Abstract.Evaluator as X
import Control.Abstract.Value as X
import Control.Effect as X
import Control.Effect.Fresh as X
import Control.Monad.Effect.Fail as X
import Control.Monad.Effect.Fresh as X
import Control.Monad.Effect.Internal as X (Eff, relay)
import Control.Monad.Effect.NonDet as X
import Control.Monad.Effect.Reader as X
import Control.Monad.Effect.State as X
@ -29,21 +24,14 @@ import Prologue
-- | A 'Monad' in which one can evaluate some specific term type to some specific value type.
--
-- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses.
class MonadEvaluator location term value m => MonadAnalysis location term value m where
-- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list.
type family Effects location term value m :: [* -> *]
class MonadEvaluator location term value effects m => MonadAnalysis location term value effects m where
-- | Analyze a term using the semantics of the current analysis.
analyzeTerm :: (Base term (Subterm term (outer value)) -> m value)
-> (Base term (Subterm term (outer value)) -> m value)
analyzeTerm :: (Base term (Subterm term (outer value)) -> m effects value)
-> (Base term (Subterm term (outer value)) -> m effects value)
-- | Analyze a module using the semantics of the current analysis. This should generally only be called by 'evaluateModule' and by definitions of 'analyzeModule' in instances for composite analyses.
analyzeModule :: (Module (Subterm term (outer value)) -> m value)
-> (Module (Subterm term (outer value)) -> m value)
-- | Isolate the given action with an empty global environment and exports.
isolate :: m a -> m a
isolate = withEnv mempty . withExports mempty
analyzeModule :: (Module (Subterm term (outer value)) -> m effects value)
-> (Module (Subterm term (outer value)) -> m effects value)
-- | Lift a 'SubtermAlgebra' for an underlying analysis into a containing analysis. Use this when defining an analysis which can be composed onto other analyses to ensure that a call to 'analyzeTerm' occurs in the inner analysis and not the outer one.
@ -51,31 +39,3 @@ liftAnalyze :: Coercible ( m effects value) (t m (effects :: [* -> *]) value)
=> ((base (Subterm term (outer value)) -> m effects value) -> (base (Subterm term (outer value)) -> m effects value))
-> ((base (Subterm term (outer value)) -> t m effects value) -> (base (Subterm term (outer value)) -> t m effects value))
liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . recur) term)
-- | Run an analysis, performing its effects and returning the result alongside any state.
--
-- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects').
runAnalysis :: ( Effectful m
, Effects location term value (m effects) ~ effects
, MonadAnalysis location term value (m effects)
, RunEffects effects a
)
=> m effects a
-> Final effects a
runAnalysis = X.run
-- | An abstraction over analyses.
data SomeAnalysis m result where
SomeAnalysis :: ( Effectful m
, effects ~ Effects location term value (m effects)
, MonadAnalysis location term value (m effects)
, RunEffects effects a
)
=> m effects a
-> SomeAnalysis m (Final effects a)
-- | Run an abstracted analysis.
runSomeAnalysis :: SomeAnalysis m result -> result
runSomeAnalysis (SomeAnalysis a) = X.run a

440
src/Control/Abstract/Evaluator.hs
View File

@ -1,34 +1,90 @@
{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, RankNTypes, TypeFamilies, UndecidableInstances #-}
{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}
module Control.Abstract.Evaluator
( MonadEvaluator(..)
, MonadEnvironment(..)
( MonadEvaluator
-- * State
, EvaluatorState(..)
-- * Environment
, getEnv
, putEnv
, modifyEnv
, withEnv
, defaultEnvironment
, withDefaultEnvironment
, fullEnvironment
, localEnv
, localize
, lookupEnv
, lookupWith
-- * Exports
, getExports
, putExports
, modifyExports
, addExport
, fullEnvironment
, MonadHeap(..)
, withExports
, isolate
-- * Heap
, getHeap
, putHeap
, modifyHeap
, localize
, lookupHeap
, assign
, MonadModuleTable(..)
-- * Roots
, askRoots
, extraRoots
-- * Configuration
, getConfiguration
-- * Module tables
, getModuleTable
, putModuleTable
, modifyModuleTable
, MonadControl(..)
, MonadThrow(..)
, askModuleTable
, localModuleTable
, getLoadStack
, putLoadStack
, modifyLoadStack
, currentModule
, currentPackage
-- * Control
, label
, goto
-- * Effects
, EvalClosure(..)
, evaluateClosureBody
, EvalModule(..)
, evaluateModule
, Return(..)
, earlyReturn
, catchReturn
, LoopControl(..)
, throwBreak
, throwContinue
, catchLoopControl
-- * Origin
, pushOrigin
) where
import Control.Effect
import Control.Monad.Effect.Resumable
import qualified Control.Monad.Effect as Eff
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Reader
import Control.Monad.Effect.State
import Data.Abstract.Address
import Data.Abstract.Configuration
import Data.Abstract.Environment as Env
import Data.Abstract.Exports as Export
import Data.Abstract.FreeVariables
import Data.Abstract.Heap
import Data.Abstract.Live
import Data.Abstract.Module
import Data.Abstract.ModuleTable
import Data.Abstract.Package
import Data.Abstract.Origin
import qualified Data.IntMap as IntMap
import Data.Semigroup.Reducer
import Prologue hiding (throwError)
import Data.Semilattice.Lower
import Lens.Micro
import Prelude hiding (fail)
import Prologue
-- | A 'Monad' providing the basic essentials for evaluation.
--
@ -36,140 +92,336 @@ import Prologue hiding (throwError)
-- - environments binding names to addresses
-- - a heap mapping addresses to (possibly sets of) values
-- - tables of modules available for import
class ( MonadControl term m
, MonadEnvironment location value m
, MonadFail m
, MonadModuleTable location term value m
, MonadHeap location value m
class ( Effectful m
, Member (Reader (Environment location value)) effects
, Member (Reader (ModuleTable [Module term])) effects
, Member (Reader (SomeOrigin term)) effects
, Member (State (EvaluatorState location term value)) effects
, Monad (m effects)
)
=> MonadEvaluator location term value m | m -> location, m -> term, m -> value where
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: Ord location => term -> m (Configuration location term value)
=> MonadEvaluator location term value effects m | m effects -> location term value
-- | A 'Monad' abstracting local and global environments.
class Monad m => MonadEnvironment location value m | m -> value, m -> location where
-- | Retrieve the environment.
getEnv :: m (Environment location value)
-- | Set the environment.
putEnv :: Environment location value -> m ()
-- | Sets the environment for the lifetime of the given action.
withEnv :: Environment location value -> m a -> m a
-- | Retrieve the default environment.
defaultEnvironment :: m (Environment location value)
-- State
-- | Set the default environment for the lifetime of an action.
-- Usually only invoked in a top-level evaluation function.
withDefaultEnvironment :: Environment location value -> m a -> m a
data EvaluatorState location term value = EvaluatorState
{ environment :: Environment location value
, heap :: Heap location value
, modules :: ModuleTable (Environment location value, value)
, loadStack :: LoadStack
, exports :: Exports location value
, jumps :: IntMap.IntMap (SomeOrigin term, term)
}
-- | Get the global export state.
getExports :: m (Exports location value)
-- | Set the global export state.
putExports :: Exports location value -> m ()
-- | Sets the global export state for the lifetime of the given action.
withExports :: Exports location value -> m a -> m a
deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value, Eq (Base term ())) => Eq (EvaluatorState location term value)
deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value, Ord (Base term ())) => Ord (EvaluatorState location term value)
deriving instance (Show (Cell location value), Show location, Show term, Show value, Show (Base term ())) => Show (EvaluatorState location term value)
-- | Run an action with a locally-modified environment.
localEnv :: (Environment location value -> Environment location value) -> m a -> m a
instance Lower (EvaluatorState location term value) where
lowerBound = EvaluatorState lowerBound lowerBound lowerBound lowerBound lowerBound lowerBound
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
lookupEnv :: Name -> m (Maybe (Address location value))
lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
-- | Look up a 'Name' in the environment, running an action with the resolved address (if any).
lookupWith :: (Address location value -> m a) -> Name -> m (Maybe a)
lookupWith with name = do
addr <- lookupEnv name
maybe (pure Nothing) (fmap Just . with) addr
-- Lenses
-- | Run a computation in a new local environment.
localize :: MonadEnvironment location value m => m a -> m a
localize = localEnv id
_environment :: Lens' (EvaluatorState location term value) (Environment location value)
_environment = lens environment (\ s e -> s {environment = e})
_heap :: Lens' (EvaluatorState location term value) (Heap location value)
_heap = lens heap (\ s h -> s {heap = h})
_modules :: Lens' (EvaluatorState location term value) (ModuleTable (Environment location value, value))
_modules = lens modules (\ s m -> s {modules = m})
_loadStack :: Lens' (EvaluatorState location term value) LoadStack
_loadStack = lens loadStack (\ s l -> s {loadStack = l})
_exports :: Lens' (EvaluatorState location term value) (Exports location value)
_exports = lens exports (\ s e -> s {exports = e})
_jumps :: Lens' (EvaluatorState location term value) (IntMap.IntMap (SomeOrigin term, term))
_jumps = lens jumps (\ s j -> s {jumps = j})
(.=) :: MonadEvaluator location term value effects m => ASetter (EvaluatorState location term value) (EvaluatorState location term value) a b -> b -> m effects ()
lens .= val = raise (modify' (lens .~ val))
view :: MonadEvaluator location term value effects m => Getting a (EvaluatorState location term value) a -> m effects a
view lens = raise (gets (^. lens))
localEvaluatorState :: MonadEvaluator location term value effects m => Lens' (EvaluatorState location term value) prj -> (prj -> prj) -> m effects a -> m effects a
localEvaluatorState lens f action = do
original <- view lens
lens .= f original
v <- action
v <$ lens .= original
-- Environment
-- | Retrieve the environment.
getEnv :: MonadEvaluator location term value effects m => m effects (Environment location value)
getEnv = view _environment
-- | Set the environment.
putEnv :: MonadEvaluator location term value effects m => Environment location value -> m effects ()
putEnv = (_environment .=)
-- | Update the global environment.
modifyEnv :: MonadEnvironment location value m => (Environment location value -> Environment location value) -> m ()
modifyEnv :: MonadEvaluator location term value effects m => (Environment location value -> Environment location value) -> m effects ()
modifyEnv f = do
env <- getEnv
putEnv $! f env
-- | Sets the environment for the lifetime of the given action.
withEnv :: MonadEvaluator location term value effects m => Environment location value -> m effects a -> m effects a
withEnv s = localEvaluatorState _environment (const s)
-- | Retrieve the default environment.
defaultEnvironment :: MonadEvaluator location term value effects m => m effects (Environment location value)
defaultEnvironment = raise ask
-- | Set the default environment for the lifetime of an action.
-- Usually only invoked in a top-level evaluation function.
withDefaultEnvironment :: MonadEvaluator location term value effects m => Environment location value -> m effects a -> m effects a
withDefaultEnvironment e = raiseHandler (local (const e))
-- | Obtain an environment that is the composition of the current and default environments.
-- Useful for debugging.
fullEnvironment :: MonadEvaluator location term value effects m => m effects (Environment location value)
fullEnvironment = mergeEnvs <$> getEnv <*> defaultEnvironment
-- | Run an action with a locally-modified environment.
localEnv :: MonadEvaluator location term value effects m => (Environment location value -> Environment location value) -> m effects a -> m effects a
localEnv f a = do
modifyEnv (f . Env.push)
result <- a
result <$ modifyEnv Env.pop
-- | Run a computation in a new local environment.
localize :: MonadEvaluator location term value effects m => m effects a -> m effects a
localize = localEnv id
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
lookupEnv :: MonadEvaluator location term value effects m => Name -> m effects (Maybe (Address location value))
lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
-- | Look up a 'Name' in the environment, running an action with the resolved address (if any).
lookupWith :: MonadEvaluator location term value effects m => (Address location value -> m effects a) -> Name -> m effects (Maybe a)
lookupWith with name = do
addr <- lookupEnv name
maybe (pure Nothing) (fmap Just . with) addr
-- Exports
-- | Get the global export state.
getExports :: MonadEvaluator location term value effects m => m effects (Exports location value)
getExports = view _exports
-- | Set the global export state.
putExports :: MonadEvaluator location term value effects m => Exports location value -> m effects ()
putExports = (_exports .=)
-- | Update the global export state.
modifyExports :: MonadEnvironment location value m => (Exports location value -> Exports location value) -> m ()
modifyExports :: MonadEvaluator location term value effects m => (Exports location value -> Exports location value) -> m effects ()
modifyExports f = do
exports <- getExports
putExports $! f exports
-- | Add an export to the global export state.
addExport :: MonadEnvironment location value m => Name -> Name -> Maybe (Address location value) -> m ()
addExport :: MonadEvaluator location term value effects m => Name -> Name -> Maybe (Address location value) -> m effects ()
addExport name alias = modifyExports . Export.insert name alias
-- | Obtain an environment that is the composition of the current and default environments.
-- Useful for debugging.
fullEnvironment :: MonadEnvironment location value m => m (Environment location value)
fullEnvironment = mappend <$> getEnv <*> defaultEnvironment
-- | Sets the global export state for the lifetime of the given action.
withExports :: MonadEvaluator location term value effects m => Exports location value -> m effects a -> m effects a
withExports s = localEvaluatorState _exports (const s)
-- | A 'Monad' abstracting a heap of values.
class Monad m => MonadHeap location value m | m -> value, m -> location where
-- | Retrieve the heap.
getHeap :: m (Heap location value)
-- | Set the heap.
putHeap :: Heap location value -> m ()
-- | Isolate the given action with an empty global environment and exports.
isolate :: MonadEvaluator location term value effects m => m effects a -> m effects a
isolate = withEnv lowerBound . withExports lowerBound
-- Heap
-- | Retrieve the heap.
getHeap :: MonadEvaluator location term value effects m => m effects (Heap location value)
getHeap = view _heap
-- | Set the heap.
putHeap :: MonadEvaluator location term value effects m => Heap location value -> m effects ()
putHeap = (_heap .=)
-- | Update the heap.
modifyHeap :: MonadHeap location value m => (Heap location value -> Heap location value) -> m ()
modifyHeap :: MonadEvaluator location term value effects m => (Heap location value -> Heap location value) -> m effects ()
modifyHeap f = do
s <- getHeap
putHeap $! f s
-- | Look up the cell for the given 'Address' in the 'Heap'.
lookupHeap :: (MonadHeap location value m, Ord location) => Address location value -> m (Maybe (Cell location value))
lookupHeap :: (MonadEvaluator location term value effects m, Ord location) => Address location value -> m effects (Maybe (Cell location value))
lookupHeap = flip fmap getHeap . heapLookup
-- | Write a value to the given 'Address' in the 'Store'.
assign :: ( Ord location
, MonadHeap location value m
, MonadEvaluator location term value effects m
, Reducer value (Cell location value)
)
=> Address location value
-> value
-> m ()
-> m effects ()
assign address = modifyHeap . heapInsert address
-- | A 'Monad' abstracting tables of modules available for import.
class Monad m => MonadModuleTable location term value m | m -> location, m -> term, m -> value where
-- | Retrieve the table of evaluated modules.
getModuleTable :: m (ModuleTable (Environment location value, value))
-- | Set the table of evaluated modules.
putModuleTable :: ModuleTable (Environment location value, value) -> m ()
-- Roots
-- | Retrieve the table of unevaluated modules.
askModuleTable :: m (ModuleTable [Module term])
-- | Run an action with a locally-modified table of unevaluated modules.
localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m a -> m a
-- | Retrieve the local 'Live' set.
askRoots :: (Effectful m, Member (Reader (Live location value)) effects) => m effects (Live location value)
askRoots = raise ask
-- | Get the currently evaluating 'ModuleInfo'.
currentModule :: m ModuleInfo
-- | Run a computation with the given 'Live' set added to the local root set.
extraRoots :: (Effectful m, Member (Reader (Live location value)) effects, Ord location) => Live location value -> m effects a -> m effects a
extraRoots roots = raiseHandler (local (<> roots))
-- Configuration
-- | Get the current 'Configuration' with a passed-in term.
getConfiguration :: (Member (Reader (Live location value)) effects, MonadEvaluator location term value effects m) => term -> m effects (Configuration location term value)
getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap
-- Module table
-- | Retrieve the table of evaluated modules.
getModuleTable :: MonadEvaluator location term value effects m => m effects (ModuleTable (Environment location value, value))
getModuleTable = view _modules
-- | Set the table of evaluated modules.
putModuleTable :: MonadEvaluator location term value effects m => ModuleTable (Environment location value, value) -> m effects ()
putModuleTable = (_modules .=)
-- | Update the evaluated module table.
modifyModuleTable :: MonadModuleTable location term value m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m ()
modifyModuleTable :: MonadEvaluator location term value effects m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m effects ()
modifyModuleTable f = do
table <- getModuleTable
putModuleTable $! f table
-- | A 'Monad' abstracting jumps in imperative control.
class Monad m => MonadControl term m where
-- | Allocate a 'Label' for the given @term@.
--
-- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms.
label :: term -> m Label
-- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance).
goto :: Label -> m term
-- | Retrieve the table of unevaluated modules.
askModuleTable :: MonadEvaluator location term value effects m => m effects (ModuleTable [Module term])
askModuleTable = raise ask
-- | Run an action with a locally-modified table of unevaluated modules.
localModuleTable :: MonadEvaluator location term value effects m => (ModuleTable [Module term] -> ModuleTable [Module term]) -> m effects a -> m effects a
localModuleTable f = raiseHandler (local f)
-- | 'Monad's which can throw exceptions of type @exc v@ which can be resumed with a value of type @v@.
class Monad m => MonadThrow exc m where
throwException :: exc v -> m v
-- | Retrieve the module load stack
getLoadStack :: MonadEvaluator location term value effects m => m effects LoadStack
getLoadStack = view _loadStack
instance (Effectful m, Members '[Resumable exc] effects, Monad (m effects)) => MonadThrow exc (m effects) where
throwException = raise . throwError
-- | Set the module load stack
putLoadStack :: MonadEvaluator location term value effects m => LoadStack -> m effects ()
putLoadStack = (_loadStack .=)
-- | Update the module load stack.
modifyLoadStack :: MonadEvaluator location term value effects m => (LoadStack -> LoadStack) -> m effects ()
modifyLoadStack f = do
stack <- getLoadStack
putLoadStack $! f stack
-- | Get the currently evaluating 'ModuleInfo'.
currentModule :: forall location term value effects m . (Member Fail effects, MonadEvaluator location term value effects m) => m effects ModuleInfo
currentModule = do
o <- raise ask
maybeM (raise (fail "unable to get currentModule")) $ withSomeOrigin (originModule @term) o
-- | Get the currently evaluating 'PackageInfo'.
currentPackage :: forall location term value effects m . (Member Fail effects, MonadEvaluator location term value effects m) => m effects PackageInfo
currentPackage = do
o <- raise ask
maybeM (raise (fail "unable to get currentPackage")) $ withSomeOrigin (originPackage @term) o
-- Control
-- | Allocate a 'Label' for the given @term@.
--
-- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms.
label :: MonadEvaluator location term value effects m => term -> m effects Label
label term = do
m <- view _jumps
origin <- raise ask
let i = IntMap.size m
_jumps .= IntMap.insert i (origin, term) m
pure i
-- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance).
goto :: (Recursive term, Member Fail effects, MonadEvaluator location term value effects m) => Label -> (term -> m effects a) -> m effects a
goto label comp = do
maybeTerm <- IntMap.lookup label <$> view _jumps
case maybeTerm of
Just (origin, term) -> pushOrigin (origin <> termOrigin term) (comp term)
Nothing -> raise (fail ("unknown label: " <> show label))
-- Effects
-- | An effect to evaluate a closure’s body.
data EvalClosure term value resume where
EvalClosure :: term -> EvalClosure term value value
evaluateClosureBody :: (Effectful m, Member (EvalClosure term value) effects) => term -> m effects value
evaluateClosureBody = raise . Eff.send . EvalClosure
-- | An effect to evaluate a module.
data EvalModule term value resume where
EvalModule :: Module term -> EvalModule term value value
evaluateModule :: (Effectful m, Member (EvalModule term value) effects) => Module term -> m effects value
evaluateModule = raise . Eff.send . EvalModule
-- | An effect for explicitly returning out of a function/method body.
data Return value resume where
Return :: value -> Return value value
deriving instance Eq value => Eq (Return value a)
deriving instance Show value => Show (Return value a)
earlyReturn :: (Effectful m, Member (Return value) effects) => value -> m effects value
earlyReturn = raise . Eff.send . Return
catchReturn :: (Effectful m, Member (Return value) effects) => m effects a -> (forall x . Return value x -> m effects a) -> m effects a
catchReturn action handler = raiseHandler (Eff.interpose pure (\ ret _ -> lower (handler ret))) action
-- | Effects for control flow around loops (breaking and continuing).
data LoopControl value resume where
Break :: value -> LoopControl value value
Continue :: LoopControl value value
deriving instance Eq value => Eq (LoopControl value a)
deriving instance Show value => Show (LoopControl value a)
throwBreak :: (Effectful m, Member (LoopControl value) effects) => value -> m effects value
throwBreak = raise . Eff.send . Break
throwContinue :: (Effectful m, Member (LoopControl value) effects) => m effects value
throwContinue = raise (Eff.send Continue)
catchLoopControl :: (Effectful m, Member (LoopControl value) effects) => m effects a -> (forall x . LoopControl value x -> m effects a) -> m effects a
catchLoopControl action handler = raiseHandler (Eff.interpose pure (\ control _ -> lower (handler control))) action
-- | Push a 'SomeOrigin' onto the stack. This should be used to contextualize execution with information about the originating term, module, or package.
pushOrigin :: ( Effectful m
, Member (Reader (SomeOrigin term)) effects
)
=> SomeOrigin term
-> m effects a
-> m effects a
pushOrigin o = raiseHandler (local (<> o))

137
src/Control/Abstract/Value.hs
View File

@ -1,13 +1,13 @@
{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies, GADTs, KindSignatures, Rank2Types #-}
module Control.Abstract.Value
( MonadValue(..)
, AbstractHole(..)
, Comparator(..)
, while
, doWhile
, forLoop
, makeNamespace
, ValueRoots(..)
, ValueError(..)
) where
import Control.Abstract.Evaluator
@ -18,6 +18,7 @@ import Data.Abstract.Live (Live)
import Data.Abstract.Number as Number
import Data.Scientific (Scientific)
import Data.Semigroup.Reducer hiding (unit)
import Data.Semilattice.Lower
import Prelude
import Prologue hiding (TypeError)
@ -31,153 +32,162 @@ data Comparator
= Concrete (forall a . Ord a => a -> a -> Bool)
| Generalized
class AbstractHole value where
hole :: 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 (Monad m, Show value) => MonadValue location value m | m value -> location where
class (Monad (m effects), Show value) => MonadValue location value (effects :: [* -> *]) m | m effects value -> location where
-- | Construct an abstract unit value.
-- TODO: This might be the same as the empty tuple for some value types
unit :: m value
unit :: m effects value
-- | Construct an abstract integral value.
integer :: Prelude.Integer -> m value
integer :: Prelude.Integer -> m effects value
-- | Lift a unary operator over a 'Num' to a function on 'value's.
liftNumeric :: (forall a . Num a => a -> a)
-> (value -> m value)
-> (value -> m effects value)
-- | 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 :: (forall a b. Number a -> Number b -> SomeNumber)
-> (value -> value -> m value)
-> (value -> value -> m effects value)
-- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
liftComparison :: Comparator -> (value -> value -> m value)
liftComparison :: Comparator -> (value -> value -> m effects value)
-- | Lift a unary bitwise operator to values. This is usually 'complement'.
liftBitwise :: (forall a . Bits a => a -> a)
-> (value -> m value)
-> (value -> m effects value)
-- | 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 :: (forall a . (Integral a, Bits a) => a -> a -> a)
-> (value -> value -> m value)
-> (value -> value -> m effects value)
-- | Construct an abstract boolean value.
boolean :: Bool -> m value
boolean :: Bool -> m effects value
-- | Construct an abstract string value.
string :: ByteString -> m value
string :: ByteString -> m effects value
-- | Construct a self-evaluating symbol value.
-- TODO: Should these be interned in some table to provide stronger uniqueness guarantees?
symbol :: ByteString -> m value
symbol :: ByteString -> m effects value
-- | Construct a floating-point value.
float :: Scientific -> m value
float :: Scientific -> m effects value
-- | Construct a rational value.
rational :: Prelude.Rational -> m value
rational :: Prelude.Rational -> m effects value
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
multiple :: [value] -> m value
multiple :: [value] -> m effects value
-- | Construct an array of zero or more values.
array :: [value] -> m value
array :: [value] -> m effects value
-- | Construct a key-value pair for use in a hash.
kvPair :: value -> value -> m value
kvPair :: value -> value -> m effects value
-- | Extract the contents of a key-value pair as a tuple.
asPair :: value -> m (value, value)
asPair :: value -> m effects (value, value)
-- | Construct a hash out of pairs.
hash :: [(value, value)] -> m value
hash :: [(value, value)] -> m effects value
-- | Extract a 'ByteString' from a given value.
asString :: value -> m ByteString
asString :: value -> m effects ByteString
-- | Eliminate boolean values. TODO: s/boolean/truthy
ifthenelse :: value -> m value -> m value -> m value
ifthenelse :: value -> m effects value -> m effects value -> m effects value
-- | Extract a 'Bool' from a given value.
asBool :: value -> m Bool
asBool :: value -> m effects Bool
-- | Construct the nil/null datatype.
null :: m value
null :: m effects value
-- | @index x i@ computes @x[i]@, with zero-indexing.
index :: value -> value -> m effects value
-- | Determine whether the given datum is a 'Hole'.
isHole :: value -> m effects Bool
-- | Build a class value from a name and environment.
klass :: Name -- ^ The new class's identifier
-> [value] -- ^ A list of superclasses
-> Environment location value -- ^ The environment to capture
-> m value
-> m effects value
-- | Build a namespace value from a name and environment stack
--
-- Namespaces model closures with monoidal environments.
namespace :: Name -- ^ The namespace's identifier
-> Environment location value -- ^ The environment to mappend
-> m value
-> m effects value
-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
scopedEnvironment :: value -> m (Environment location value)
scopedEnvironment :: value -> m effects (Maybe (Environment location value))
-- | Evaluate an abstraction (a binder like a lambda or method definition).
lambda :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value
lambda :: (FreeVariables term, MonadEvaluator location term value effects m) => [Name] -> Subterm term (m effects value) -> m effects value
-- | Evaluate an application (like a function call).
call :: value -> [m value] -> m value
call :: value -> [m effects value] -> m effects value
-- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
--
-- The function argument takes an action which recurs through the loop.
loop :: (m value -> m value) -> m value
loop :: (m effects value -> m effects value) -> m effects value
-- | Attempt to extract a 'Prelude.Bool' from a given value.
forLoop :: (MonadEnvironment location value m, MonadValue location value m)
=> m value -- ^ Initial statement
-> m value -- ^ Condition
-> m value -- ^ Increment/stepper
-> m value -- ^ Body
-> m value
forLoop :: (MonadEvaluator location term value effects m, MonadValue location value effects m)
=> m effects value -- ^ Initial statement
-> m effects value -- ^ Condition
-> m effects value -- ^ Increment/stepper
-> m effects value -- ^ Body
-> m effects value
forLoop initial cond step body =
localize (initial *> while cond (body *> step))
-- | The fundamental looping primitive, built on top of ifthenelse.
while :: MonadValue location value m
=> m value
-> m value
-> m value
while :: MonadValue location value effects m
=> m effects value
-> m effects value
-> m effects value
while cond body = loop $ \ continue -> do
this <- cond
ifthenelse this (body *> continue) unit
-- | Do-while loop, built on top of while.
doWhile :: MonadValue location value m
=> m value
-> m value
-> m value
doWhile :: MonadValue location value effects m
=> m effects value
-> m effects value
-> m effects value
doWhile body cond = loop $ \ continue -> body *> do
this <- cond
ifthenelse this continue unit
makeNamespace :: ( MonadValue location value m
, MonadEnvironment location value m
, MonadHeap location value m
makeNamespace :: ( MonadValue location value effects m
, MonadEvaluator location term value effects m
, Ord location
, Reducer value (Cell location value)
)
=> Name
-> Address location value
-> [value]
-> m value
makeNamespace name addr supers = do
superEnv <- mconcat <$> traverse scopedEnvironment supers
-> Maybe value
-> m effects value
makeNamespace name addr super = do
superEnv <- maybe (pure (Just lowerBound)) scopedEnvironment super
let env' = fromMaybe lowerBound superEnv
namespaceEnv <- Env.head <$> getEnv
v <- namespace name (Env.mergeNewer superEnv namespaceEnv)
v <- namespace name (Env.mergeNewer env' namespaceEnv)
v <$ assign addr v
@ -185,26 +195,3 @@ makeNamespace name addr supers = do
class ValueRoots location value where
-- | Compute the set of addresses rooted by a given value.
valueRoots :: value -> Live location value
-- The type of exceptions that can be thrown when constructing values in `MonadValue`.
data ValueError location value resume where
StringError :: value -> ValueError location value ByteString
NamespaceError :: Prelude.String -> ValueError location value (Environment location value)
ScopedEnvironmentError :: Prelude.String -> ValueError location value (Environment location value)
CallError :: value -> ValueError location value value
BoolError :: value -> ValueError location value Bool
Numeric2Error :: value -> value -> ValueError location value value
instance Eq value => Eq1 (ValueError location value) where
liftEq _ (StringError a) (StringError b) = a == b
liftEq _ (NamespaceError a) (NamespaceError b) = a == b
liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b
liftEq _ (CallError a) (CallError b) = a == b
liftEq _ (BoolError a) (BoolError c) = a == c
liftEq _ (Numeric2Error a b) (Numeric2Error c d) = (a == c) && (b == d)
liftEq _ _ _ = False
deriving instance (Show value) => Show (ValueError location value resume)
instance (Show value) => Show1 (ValueError location value) where
liftShowsPrec _ _ = showsPrec

107
src/Control/Effect.hs
View File

@ -1,92 +1,26 @@
{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies, RankNTypes, TypeFamilies, TypeOperators #-}
module Control.Effect
( Control.Effect.run
, RunEffects(..)
, RunEffect(..)
, Effectful(..)
, resumeException
, mergeEither
( Effectful(..)
, raiseHandler
, Interpreter(..)
, throwResumable
, resume
) where
import Control.Monad.Effect as Effect
import Control.Monad.Effect.Fail
import Control.Monad.Effect.NonDet
import Control.Monad.Effect.Reader
import Control.Monad.Effect.Resumable
import Control.Monad.Effect.State
import Control.Monad.Effect.Writer
import Data.Semigroup.Reducer
import Prologue
import Control.Monad.Effect as Effect
import Control.Monad.Effect.Resumable as Resumable
-- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result.
run :: (Effectful m, RunEffects effects a) => m effects a -> Final effects a
run = runEffects . lower
throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v
throwResumable = raise . throwError
-- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults.
class RunEffects fs a where
-- | The final result type of the computation, factoring in the results of any effects, e.g. pairing 'State' results with the final state, wrapping 'Fail' results in 'Either', etc.
type Final fs a
runEffects :: Eff fs a -> Final fs a
instance (RunEffect f a, RunEffects fs (Result f a)) => RunEffects (f ': fs) a where
type Final (f ': fs) a = Final fs (Result f a)
runEffects = runEffects . runEffect
instance RunEffects '[] a where
type Final '[] a = a
runEffects = Effect.run
-- | A typeclass to interpret a single effect with some sensible defaults (defined per-effect).
class RunEffect f a where
-- | The incremental result of an effect w.r.t. the parameter value, factoring in the interpretation of the effect.
type Result f a
type instance Result f a = a
-- | Interpret the topmost effect in a computation with some sensible defaults (defined per-effect), and return the incremental 'Result'.
runEffect :: Eff (f ': fs) a -> Eff fs (Result f a)
-- | 'State' effects with 'Monoid'al states are interpreted starting from the 'mempty' state value into a pair of result value and final state.
instance Monoid b => RunEffect (State b) a where
type Result (State b) a = (a, b)
runEffect = flip runState mempty
-- | 'Reader' effects with 'Monoid'al environments are interpreted starting from the 'mempty' environment value.
instance Monoid b => RunEffect (Reader b) a where
runEffect = flip runReader mempty
-- | 'Fail' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'.
instance RunEffect Fail a where
type Result Fail a = Either String a
runEffect = runFail
-- | 'Writer' effects are interpreted into a pair of result value and final log.
instance Monoid w => RunEffect (Writer w) a where
type Result (Writer w) a = (a, w)
runEffect = runWriter
-- | 'NonDet' effects are interpreted into a nondeterministic set of result values.
instance Ord a => RunEffect NonDet a where
type Result NonDet a = Set a
runEffect = runNonDet unit
-- | 'Resumable' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'.
instance RunEffect (Resumable exc) a where
type Result (Resumable exc) a = Either (SomeExc exc) a
runEffect = runError
resumeException :: (Resumable exc :< e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a
resumeException m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
-- | Reassociate 'Either's, combining errors into 'Left' values and successes in a single level of 'Right'.
mergeEither :: Either a (Either b c) -> Either (Either a b) c
mergeEither = either (Left . Left) (either (Left . Right) Right)
resume :: (Member (Resumable exc) e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a
resume m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
-- | Types wrapping 'Eff' actions.
--
-- Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). Because of this, types can be nested arbitrarily deeply and still call 'raise'/'lower' just once to get at the (ultimately) underlying 'Eff'.
class Effectful (m :: [* -> *] -> * -> *) where
class Effectful m where
-- | Raise an action in 'Eff' into an action in @m@.
raise :: Eff effects a -> m effects a
-- | Lower an action in @m@ into an action in 'Eff'.
@ -95,3 +29,18 @@ class Effectful (m :: [* -> *] -> * -> *) where
instance Effectful Eff where
raise = id
lower = id
raiseHandler :: Effectful m => (Eff effectsA a -> Eff effectsB b) -> m effectsA a -> m effectsB b
raiseHandler handler = raise . handler . lower
-- | Interpreters determine and interpret a list of effects, optionally taking extra arguments.
--
-- Instances will generally be defined recursively in terms of underlying interpreters, bottoming out with the instance for 'Eff' which uses 'Effect.run' to produce a final value.
class Effectful m => Interpreter m effects | m -> effects where
type Result m effects result
type instance Result m effects result = result
interpret :: m effects result -> Result m effects result
instance Interpreter Eff '[] where
interpret = Effect.run

31
src/Control/Effect/Fresh.hs
View File

@ -1,31 +0,0 @@
{-# LANGUAGE GADTs, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Control.Effect.Fresh where
import Control.Effect
import Control.Monad.Effect.Internal
-- | An effect offering a (resettable) sequence of always-incrementing, and therefore “fresh,” type variables.
data Fresh a where
-- | Request a reset of the sequence of variable names.
Reset :: Int -> Fresh ()
-- | Request a fresh variable name.
Fresh :: Fresh Int
-- | 'Monad's offering a (resettable) sequence of guaranteed-fresh type variables.
class Monad m => MonadFresh m where
-- | Get a fresh variable name, guaranteed unused (since the last 'reset').
fresh :: m Int
-- | Reset the sequence of variable names. Useful to avoid complicated alpha-equivalence comparisons when iteratively recomputing the results of an analysis til convergence.
reset :: Int -> m ()
instance (Fresh :< fs) => MonadFresh (Eff fs) where
fresh = send Fresh
reset = send . Reset
-- | 'Fresh' effects are interpreted starting from 0, incrementing the current name with each request for a fresh name, and overwriting the counter on reset.
instance RunEffect Fresh a where
runEffect = relayState (0 :: Int) (const pure) (\ s action k -> case action of
Fresh -> k (succ s) s
Reset s' -> k s' ())

26
src/Data/Abstract/Declarations.hs Normal file
View File

@ -0,0 +1,26 @@
{-# LANGUAGE UndecidableInstances #-}
module Data.Abstract.Declarations where
import Data.Abstract.FreeVariables
import Data.Term
import Prologue
class Declarations syntax where
declaredName :: syntax -> Maybe Name
declaredName = const Nothing
class Declarations1 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.
liftDeclaredName :: (a -> [Name]) -> syntax a -> Maybe Name
liftDeclaredName _ _ = Nothing
instance Declarations t => Declarations (Subterm t a) where
declaredName = declaredName . subterm
instance (FreeVariables1 syntax, Declarations1 syntax, Functor syntax) => Declarations (Term syntax ann) where
declaredName = liftDeclaredName freeVariables . termOut
instance (Apply Declarations1 fs) => Declarations1 (Union fs) where
liftDeclaredName f = apply (Proxy :: Proxy Declarations1) (liftDeclaredName f)
instance Declarations1 []

45
src/Data/Abstract/Environment.hs
View File

@ -5,12 +5,15 @@ module Data.Abstract.Environment
, bind
, delete
, head
, emptyEnv
, mergeEnvs
, mergeNewer
, insert
, lookup
, names
, overwrite
, pairs
, unpairs
, pop
, push
, roots
@ -22,13 +25,13 @@ import Data.Abstract.FreeVariables
import Data.Abstract.Live
import Data.Align
import qualified Data.Map as Map
import Data.Semigroup.Reducer
import Data.Semilattice.Lower
import GHC.Exts (IsList (..))
import Prologue
import qualified Data.List.NonEmpty as NonEmpty
-- $setup
-- >>> let bright = push (insert (name "foo") (Address (Precise 0)) mempty)
-- >>> let bright = push (insert (name "foo") (Address (Precise 0)) emptyEnv)
-- >>> let shadowed = insert (name "foo") (Address (Precise 1)) bright
-- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
@ -49,18 +52,12 @@ instance IsList (Environment l a) where
fromList xs = Environment (Map.fromList xs :| [])
toList (Environment (x :| _)) = Map.toList x
-- TODO: property-check me
instance Semigroup (Environment l a) where
Environment (a :| as) <> Environment (b :| bs) =
Environment ((a <> b) :| alignWith (mergeThese (<>)) as bs)
mergeEnvs :: Environment l a -> Environment l a -> Environment l a
mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
instance Reducer (Name, Address l a) (Environment l a) where
unit a = Environment (unit a :| [])
-- | This instance is possibly unlawful. If this breaks, you get to keep both pieces.
instance Monoid (Environment l a) where
mappend = (<>)
mempty = Environment (mempty :| [])
emptyEnv :: Environment l a
emptyEnv = Environment (lowerBound :| [])
-- | Make and enter a new empty scope in the given environment.
push :: Environment l a -> Environment l a
@ -68,7 +65,7 @@ push (Environment (a :| as)) = Environment (mempty :| a : as)
-- | Remove the frontmost scope.
pop :: Environment l a -> Environment l a
pop (Environment (_ :| [])) = mempty
pop (Environment (_ :| [])) = emptyEnv
pop (Environment (_ :| a : as)) = Environment (a :| as)
-- | Drop all scopes save for the frontmost one.
@ -92,6 +89,9 @@ mergeNewer (Environment a) (Environment b) =
pairs :: Environment l a -> [(Name, Address l a)]
pairs = Map.toList . fold . unEnvironment
unpairs :: [(Name, Address l a)] -> Environment l a
unpairs = fromList
-- | Lookup a 'Name' in the environment.
--
-- >>> lookup (name "foo") shadowed
@ -115,19 +115,19 @@ trim (Environment (a :| as)) = Environment (a :| filtered)
where filtered = filter (not . Map.null) as
bind :: Foldable t => t Name -> Environment l a -> Environment l a
bind names env = foldMap envForName names
where envForName name = maybe mempty (curry unit name) (lookup name env)
bind names env = fromList (mapMaybe lookupName (Prologue.toList names))
where
lookupName name = (,) name <$> lookup name env
-- | Get all bound 'Name's in an environment.
names :: Environment l a -> [Name]
names = fmap fst . pairs
-- | Overwrite a set of key-value bindings in the provided environment.
-- | Lookup and alias name-value bindings from an environment.
overwrite :: [(Name, Name)] -> Environment l a -> Environment l a
overwrite pairs env = foldMap go pairs where
go (k, v) = case lookup k env of
Nothing -> mempty
Just addr -> unit (v, addr)
overwrite pairs env = fromList $ mapMaybe lookupAndAlias pairs
where
lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
-- | Retrieve the 'Live' set of addresses to which the given free variable names are bound.
--
@ -137,3 +137,6 @@ roots env = foldMap (maybe mempty liveSingleton . flip lookup env)
addresses :: Ord l => Environment l a -> Live l a
addresses = Live . fromList . fmap snd . pairs
instance Lower (Environment location value) where lowerBound = emptyEnv

285
src/Data/Abstract/Evaluatable.hs
View File

@ -1,80 +1,92 @@
{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Evaluatable
( module X
, MonadEvaluatable
, Evaluatable(..)
, Unspecialized(..)
, LoadError(..)
, EvalError(..)
, LoadError(..)
, ResolutionError(..)
, variable
, evaluateTerm
, evaluateModule
, evaluateModules
, evaluateInScopedEnv
, evaluatePackage
, evaluatePackageBody
, throwLoadError
, throwEvalError
, throwValueError
, resolve
, traceResolve
, listModulesInDir
, require
, load
, pushOrigin
) where
import Control.Abstract.Addressable as X
import Control.Abstract.Analysis as X
import Control.Abstract.Analysis as X hiding (LoopControl(..), Return(..))
import Control.Abstract.Analysis (LoopControl, Return(..))
import Control.Monad.Effect as Eff
import Data.Abstract.Address
import Data.Abstract.Declarations as X
import Data.Abstract.Environment as X
import qualified Data.Abstract.Exports as Exports
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Origin (SomeOrigin, packageOrigin)
import Data.Abstract.Origin (packageOrigin)
import Data.Abstract.Package as Package
import Data.Language
import Data.Scientific (Scientific)
import Data.Semigroup.App
import Data.Semigroup.Foldable
import Data.Semigroup.Reducer hiding (unit)
import Data.Term
import Prologue
type MonadEvaluatable location term value m =
( Evaluatable (Base term)
type MonadEvaluatable location term value effects m =
( Declarations term
, Evaluatable (Base term)
, FreeVariables term
, MonadAddressable location m
, MonadAnalysis location term value m
, MonadThrow (Unspecialized value) m
, MonadThrow (ValueError location value) m
, MonadThrow (LoadError term value) m
, MonadThrow (EvalError value) m
, MonadThrow (ResolutionError value) m
, MonadValue location value m
, Member (EvalClosure term value) effects
, Member (EvalModule term value) effects
, Member Fail effects
, Member (LoopControl value) effects
, Member (Resumable (Unspecialized value)) effects
, Member (Resumable (LoadError term)) effects
, Member (Resumable (EvalError value)) effects
, Member (Resumable (ResolutionError value)) effects
, Member (Resumable (AddressError location value)) effects
, Member (Return value) effects
, MonadAddressable location effects m
, MonadEvaluator location term value effects m
, MonadValue location value effects m
, Recursive term
, Reducer value (Cell location value)
, Show location
)
-- | An error thrown when we can't resolve a module from a qualified name.
data ResolutionError value resume where
RubyError :: String -> ResolutionError value ModulePath
NotFoundError :: String -- ^ The path that was not found.
-> [String] -- ^ List of paths searched that shows where semantic looked for this module.
-> Language -- ^ Language.
-> ResolutionError value ModulePath
GoImportError :: FilePath -> ResolutionError value [ModulePath]
deriving instance Eq (ResolutionError a b)
deriving instance Show (ResolutionError a b)
instance Show1 (ResolutionError value) where
liftShowsPrec _ _ = showsPrec
instance Show1 (ResolutionError value) where liftShowsPrec _ _ = showsPrec
instance Eq1 (ResolutionError value) where
liftEq _ (RubyError a) (RubyError b) = a == b
liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2
liftEq _ (GoImportError a) (GoImportError b) = a == b
liftEq _ _ _ = False
-- | 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 term value resume where
LoadError :: ModulePath -> LoadError term value [Module term]
data LoadError term resume where
LoadError :: ModulePath -> LoadError term [Module term]
deriving instance Eq (LoadError term a b)
deriving instance Show (LoadError term a b)
instance Show1 (LoadError term value) where
deriving instance Eq (LoadError term resume)
deriving instance Show (LoadError term resume)
instance Show1 (LoadError term) where
liftShowsPrec _ _ = showsPrec
instance Eq1 (LoadError term a) where
instance Eq1 (LoadError term) where
liftEq _ (LoadError a) (LoadError b) = a == b
-- | The type of error thrown when failing to evaluate a term.
@ -82,29 +94,54 @@ data EvalError value resume where
-- Indicates we weren't able to dereference a name from the evaluated environment.
FreeVariableError :: Name -> EvalError value value
FreeVariablesError :: [Name] -> EvalError value Name
-- Indicates that our evaluator wasn't able to make sense of these literals.
IntegerFormatError :: ByteString -> EvalError value Integer
FloatFormatError :: ByteString -> EvalError value Scientific
RationalFormatError :: ByteString -> EvalError value Rational
DefaultExportError :: EvalError value ()
ExportError :: ModulePath -> Name -> EvalError value ()
EnvironmentLookupError :: value -> EvalError value value
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
-- Throws an 'EnvironmentLookupError' if @scopedEnvTerm@ does not have an environment.
evaluateInScopedEnv :: MonadEvaluatable location term value effects m
=> m effects value
-> m effects value
-> m effects value
evaluateInScopedEnv scopedEnvTerm term = do
value <- scopedEnvTerm
scopedEnv <- scopedEnvironment value
maybe (throwEvalError (EnvironmentLookupError value)) (flip localEnv term . mergeEnvs) scopedEnv
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
variable :: MonadEvaluatable location term value m => Name -> m value
variable name = lookupWith deref name >>= maybeM (throwException (FreeVariableError name))
variable :: ( Member (Resumable (AddressError location value)) effects
, Member (Resumable (EvalError value)) effects
, MonadAddressable location effects m
, MonadEvaluator location term value effects m
)
=> Name
-> m effects value
variable name = lookupWith deref name >>= maybeM (throwResumable (FreeVariableError name))
deriving instance Eq (EvalError a b)
deriving instance Show (EvalError a b)
instance Show1 (EvalError value) where
deriving instance Eq a => Eq (EvalError a b)
deriving instance Show a => Show (EvalError a b)
instance Show value => Show1 (EvalError value) where
liftShowsPrec _ _ = showsPrec
instance Eq1 (EvalError term) where
liftEq _ (FreeVariableError a) (FreeVariableError b) = a == b
liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b
liftEq _ _ _ = False
instance Eq term => Eq1 (EvalError term) where
liftEq _ (FreeVariableError a) (FreeVariableError b) = a == b
liftEq _ (FreeVariablesError a) (FreeVariablesError b) = a == b
liftEq _ DefaultExportError DefaultExportError = True
liftEq _ (ExportError a b) (ExportError c d) = (a == c) && (b == d)
liftEq _ (IntegerFormatError a) (IntegerFormatError b) = a == b
liftEq _ (FloatFormatError a) (FloatFormatError b) = a == b
liftEq _ (RationalFormatError a) (RationalFormatError b) = a == b
liftEq _ (EnvironmentLookupError a) (EnvironmentLookupError b) = a == b
liftEq _ _ _ = False
throwValueError :: MonadEvaluatable location term value m => ValueError location value resume -> m resume
throwValueError = throwException
throwEvalError :: (Member (Resumable (EvalError value)) effects, MonadEvaluator location term value effects m) => EvalError value resume -> m effects resume
throwEvalError = throwResumable
throwLoadError :: MonadEvaluatable location term value m => LoadError term value resume -> m resume
throwLoadError = throwException
throwEvalError :: MonadEvaluatable location term value m => EvalError value resume -> m resume
throwEvalError = throwException
data Unspecialized a b where
Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value
@ -119,10 +156,10 @@ instance Show1 (Unspecialized a) where
-- | 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 Evaluatable constr where
eval :: MonadEvaluatable location term value m
=> SubtermAlgebra constr term (m value)
default eval :: (MonadThrow (Unspecialized value) m, Show1 constr) => SubtermAlgebra constr term (m value)
eval expr = throwException (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
eval :: MonadEvaluatable location term value effects m
=> SubtermAlgebra constr term (m effects value)
default eval :: (MonadEvaluatable location term value effects m, Show1 constr) => SubtermAlgebra constr term (m effects value)
eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
-- Instances
@ -145,48 +182,87 @@ instance Evaluatable [] where
eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty
-- Resolve a list of module paths to a possible module table entry.
resolve :: MonadEvaluatable location term value m
resolve :: MonadEvaluatable location term value effects m
=> [FilePath]
-> m (Maybe ModulePath)
-> m effects (Maybe ModulePath)
resolve names = do
tbl <- askModuleTable
pure $ find (`ModuleTable.member` tbl) names
listModulesInDir :: MonadEvaluatable location term value m
traceResolve :: (Show a, Show b) => a -> b -> c -> c
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
listModulesInDir :: MonadEvaluatable location term value effects m
=> FilePath
-> m [ModulePath]
-> m effects [ModulePath]
listModulesInDir dir = ModuleTable.modulePathsInDir dir <$> askModuleTable
-- | Require/import another module by name and return it's environment and value.
--
-- Looks up the term's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
require :: MonadEvaluatable location term value m
require :: ( Member (EvalModule term value) effects
, Member (Resumable (LoadError term)) effects
, MonadEvaluator location term value effects m
, MonadValue location value effects m
)
=> ModulePath
-> m (Environment location value, value)
require name = getModuleTable >>= maybeM (load name) . ModuleTable.lookup name
-> m effects (Environment location value, value)
require = requireWith evaluateModule
requireWith :: ( Member (Resumable (LoadError term)) effects
, MonadEvaluator location term value effects m
, MonadValue location value effects m
)
=> (Module term -> m effects value)
-> ModulePath
-> m effects (Environment location value, value)
requireWith with name = getModuleTable >>= maybeM (loadWith with name) . ModuleTable.lookup name
-- | Load another module by name and return it's environment and value.
--
-- Always loads/evaluates.
load :: MonadEvaluatable location term value m
load :: ( Member (EvalModule term value) effects
, Member (Resumable (LoadError term)) effects
, MonadEvaluator location term value effects m
, MonadValue location value effects m
)
=> ModulePath
-> m (Environment location value, value)
load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= evalAndCache
where
notFound = throwLoadError (LoadError name)
-> m effects (Environment location value, value)
load = loadWith evaluateModule
evalAndCache [] = (,) mempty <$> unit
loadWith :: ( Member (Resumable (LoadError term)) effects
, MonadEvaluator location term value effects m
, MonadValue location value effects m
)
=> (Module term -> m effects value)
-> ModulePath
-> m effects (Environment location value, value)
loadWith with name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= evalAndCache
where
notFound = throwResumable (LoadError name)
evalAndCache [] = (,) emptyEnv <$> unit
evalAndCache [x] = evalAndCache' x
evalAndCache (x:xs) = do
(env, _) <- evalAndCache' x
(env', v') <- evalAndCache xs
pure (env <> env', v')
pure (mergeEnvs env env', v')
evalAndCache' x = do
v <- evaluateModule x
env <- filterEnv <$> getExports <*> getEnv
modifyModuleTable (ModuleTable.insert name (env, v))
pure (env, v)
let mPath = modulePath (moduleInfo x)
LoadStack{..} <- getLoadStack
if mPath `elem` unLoadStack
then do -- Circular load, don't keep evaluating.
v <- trace ("load (skip evaluating, circular load): " <> show mPath) unit
pure (emptyEnv, v)
else do
modifyLoadStack (loadStackPush mPath)
v <- trace ("load (evaluating): " <> show mPath) $ with x
modifyLoadStack loadStackPop
traceM ("load done:" <> show mPath)
env <- filterEnv <$> getExports <*> getEnv
modifyModuleTable (ModuleTable.insert name (env, v))
pure (env, v)
-- TODO: If the set of exports is empty because no exports have been
-- defined, do we export all terms, or no terms? This behavior varies across
@ -194,53 +270,46 @@ load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= eva
filterEnv :: Exports.Exports l a -> Environment l a -> Environment l a
filterEnv ports env
| Exports.null ports = env
| otherwise = Exports.toEnvironment ports <> overwrite (Exports.aliases ports) env
| otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env
-- | Evaluate a term to a value using the semantics of the current analysis.
--
-- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'.
evaluateTerm :: MonadEvaluatable location term value m
=> term
-> m value
evaluateTerm = foldSubterms (analyzeTerm eval)
-- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs, or (via 'evaluateModules') the entry point of multi-term programs.
evaluateModule :: MonadEvaluatable location term value m
=> Module term
-> m value
evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m)
-- | Evaluate with a list of modules in scope, taking the head module as the entry point.
evaluateModules :: MonadEvaluatable location term value m
=> [Module term]
-> m value
evaluateModules = fmap Prelude.head . evaluatePackageBody . Package.fromModules
-- | Evaluate a (root-level) term to a value using the semantics of the current analysis.
evalModule :: forall location term value effects m
. ( MonadAnalysis location term value effects m
, MonadEvaluatable location term value effects m
)
=> Module term
-> m effects value
evalModule m = raiseHandler
(interpose @(EvalModule term value) pure (\ (EvalModule m) yield -> lower @m (evalModule m) >>= yield))
(analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evalTerm) m))
where evalTerm term = catchReturn @m @value
(raiseHandler
(interpose @(EvalClosure term value) pure (\ (EvalClosure term) yield -> lower (evalTerm term) >>= yield))
(foldSubterms (analyzeTerm eval) term))
(\ (Return value) -> pure value)
-- | Evaluate a given package.
evaluatePackage :: ( Effectful m
, Member (Reader (SomeOrigin term)) effects
, MonadEvaluatable location term value (m effects)
evaluatePackage :: ( MonadAnalysis location term value effects m
, MonadEvaluatable location term value effects m
)
=> Package term
-> m effects [value]
evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBody p))
-- | Evaluate a given package body (module table and entry points).
evaluatePackageBody :: MonadEvaluatable location term value m
evaluatePackageBody :: ( MonadAnalysis location term value effects m
, MonadEvaluatable location term value effects m
)
=> PackageBody term
-> m [value]
evaluatePackageBody body = localModuleTable (<> packageModules body)
(traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body)))
where evaluateEntryPoint (m, sym) = do
(_, v) <- require m
maybe (pure v) ((`call` []) <=< variable) sym
-- | Push a 'SomeOrigin' onto the stack. This should be used to contextualize execution with information about the originating term, module, or package.
pushOrigin :: ( Effectful m
, Member (Reader (SomeOrigin term)) effects
)
=> SomeOrigin term
-> m effects a
-> m effects a
pushOrigin o = raise . local (<> o) . lower
-> m effects [value]
evaluatePackageBody body = withPrelude (packagePrelude body) $
localModuleTable (<> packageModules body) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body)))
where
evaluateEntryPoint (m, sym) = do
(_, v) <- requireWith evalModule m
maybe (pure v) ((`call` []) <=< variable) sym
withPrelude Nothing a = a
withPrelude (Just prelude) a = do
preludeEnv <- evalModule prelude *> getEnv
withDefaultEnvironment preludeEnv a

13
src/Data/Abstract/Exports.hs
View File

@ -10,22 +10,23 @@ module Data.Abstract.Exports
import Prelude hiding (null)
import Prologue hiding (null)
import Data.Abstract.Address
import Data.Abstract.Environment (Environment)
import Data.Abstract.Environment (Environment, unpairs)
import Data.Abstract.FreeVariables
import qualified Data.Map as Map
import Data.Semigroup.Reducer
import Data.Semilattice.Lower
-- | A map of export names to an alias & address tuple.
newtype Exports l a = Exports { unExports :: Map.Map Name (Name, Maybe (Address l a)) }
deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable)
deriving (Eq, Foldable, Functor, Generic1, Lower, Monoid, Ord, Semigroup, Show, Traversable)
null :: Exports l a -> Bool
null = Map.null . unExports
toEnvironment :: Exports l a -> Environment l a
toEnvironment = Map.foldMapWithKey buildEnv . unExports where
buildEnv _ (_, Nothing) = mempty
buildEnv _ (n, Just a) = unit (n, a)
toEnvironment exports = unpairs (mapMaybe collectExport (toList (unExports exports)))
where
collectExport (_, Nothing) = Nothing
collectExport (n, Just a) = Just (n, a)
insert :: Name -> Name -> Maybe (Address l a) -> Exports l a -> Exports l a
insert name alias address = Exports . Map.insert name (alias, address) . unExports

3
src/Data/Abstract/FreeVariables.hs
View File

@ -45,6 +45,9 @@ freeVariable term = case freeVariables term of
[n] -> Right n
xs -> Left xs
instance (FreeVariables t) => FreeVariables (Subterm t a) where
freeVariables = freeVariables . subterm
instance (FreeVariables1 syntax, Functor syntax) => FreeVariables (Term syntax ann) where
freeVariables = cata (liftFreeVariables id)

3
src/Data/Abstract/Heap.hs
View File

@ -5,11 +5,12 @@ import Data.Abstract.Address
import Data.Abstract.Live
import qualified Data.Map.Monoidal as Monoidal
import Data.Semigroup.Reducer
import Data.Semilattice.Lower
import Prologue
-- | A map of addresses onto cells holding their values.
newtype Heap l a = Heap { unHeap :: Monoidal.Map l (Cell l a) }
deriving (Generic1)
deriving (Generic1, Lower)
deriving instance (Eq l, Eq (Cell l a)) => Eq (Heap l a)
deriving instance (Ord l, Ord (Cell l a)) => Ord (Heap l a)

4
src/Data/Abstract/Located.hs
View File

@ -19,10 +19,10 @@ instance (Location location, Ord (Base term ())) => Location (Located location t
instance ( Effectful m
, Member (Reader (SomeOrigin term)) effects
, MonadAddressable location (m effects)
, MonadAddressable location effects m
, Ord (Base term ())
)
=> MonadAddressable (Located location term) (m effects) where
=> MonadAddressable (Located location term) effects m where
derefCell (Address (Located loc _)) = derefCell (Address loc)
allocLoc name = Located <$> allocLoc name <*> raise ask

8
src/Data/Abstract/Module.hs
View File

@ -11,7 +11,7 @@ import System.FilePath.Posix
type ModulePath = FilePath
data ModuleInfo = ModuleInfo { modulePath :: FilePath, moduleRoot :: FilePath }
newtype ModuleInfo = ModuleInfo { modulePath :: FilePath }
deriving (Eq, Ord, Show)
data Module term = Module { moduleInfo :: ModuleInfo, moduleBody :: term }
@ -27,7 +27,5 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo
-> term -- ^ The @term@ representing the body of the module.
-> Module term -- ^ A 'Module' named appropriate for the 'Blob', holding the @term@, and constructed relative to the root 'FilePath', if any.
moduleForBlob rootDir Blob{..} = Module info
where
root = fromMaybe (takeDirectory blobPath) rootDir
modulePath = maybe takeFileName makeRelative rootDir
info = ModuleInfo (modulePath blobPath) root
where root = fromMaybe (takeDirectory blobPath) rootDir
info = ModuleInfo (makeRelative root blobPath)

23
src/Data/Abstract/ModuleTable.hs
View File

@ -7,20 +7,25 @@ module Data.Abstract.ModuleTable
, member
, modulePathsInDir
, insert
, keys
, fromModules
, toPairs
, LoadStack (..)
, loadStackPush
, loadStackPop
) where
import Data.Abstract.Module
import qualified Data.Map as Map
import Data.Semigroup
import Data.Semilattice.Lower
import Prologue
import System.FilePath.Posix
import GHC.Generics (Generic1)
import Prelude hiding (lookup)
newtype ModuleTable a = ModuleTable { unModuleTable :: Map.Map ModulePath a }
deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable)
deriving (Eq, Foldable, Functor, Generic1, Lower, Monoid, Ord, Semigroup, Show, Traversable)
singleton :: ModulePath -> a -> ModuleTable a
singleton name = ModuleTable . Map.singleton name
@ -37,11 +42,25 @@ 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 list of 'Module's.
fromModules :: [Module term] -> ModuleTable [Module term]
fromModules modules = let x = ModuleTable (Map.fromListWith (<>) (map toEntry modules)) in traceShow x x
fromModules modules = ModuleTable (Map.fromListWith (<>) (map toEntry modules))
where toEntry m = (modulePath (moduleInfo m), [m])
toPairs :: ModuleTable a -> [(ModulePath, a)]
toPairs = Map.toList . unModuleTable
-- | Stack of module paths used to help break circular loads/imports.
newtype LoadStack = LoadStack { unLoadStack :: [ModulePath] }
deriving (Eq, Lower, Monoid, Ord, Semigroup, Show)
loadStackPush :: ModulePath -> LoadStack -> LoadStack
loadStackPush x LoadStack{..} = LoadStack (x : unLoadStack)
loadStackPop :: LoadStack -> LoadStack
loadStackPop (LoadStack []) = LoadStack []
loadStackPop (LoadStack (_:xs)) = LoadStack xs

6
src/Data/Abstract/Number.hs
View File

@ -6,6 +6,7 @@ module Data.Abstract.Number
, liftReal
, liftIntegralFrac
, liftedExponent
, liftedFloorDiv
) where
import Data.Scientific
@ -96,3 +97,8 @@ 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

6
src/Data/Abstract/Origin.hs
View File

@ -3,6 +3,7 @@ module Data.Abstract.Origin where
import qualified Data.Abstract.Module as M
import qualified Data.Abstract.Package as P
import Data.Semilattice.Lower
import Prologue
-- | An 'Origin' encapsulates the location at which a name is bound or allocated.
@ -52,6 +53,9 @@ liftCompareOrigins c (Term m1 t1) (Term m2 t2) = liftCompareOrigins c m1 m2
instance Ord (Base term ()) => Ord (Origin term ty) where
compare = liftCompareOrigins compare
instance Lower (Origin term ty) where lowerBound = Unknown
-- | An existential abstraction over 'Origin's of different types.
data SomeOrigin term where
SomeOrigin :: Origin term ty -> SomeOrigin term
@ -98,3 +102,5 @@ instance Semigroup (SomeOrigin term) where
instance Monoid (SomeOrigin term) where
mempty = SomeOrigin Unknown
mappend = (<>)
instance Lower (SomeOrigin term) where lowerBound = SomeOrigin lowerBound

16
src/Data/Abstract/Package.hs
View File

@ -1,8 +1,10 @@
{-# LANGUAGE TupleSections #-}
module Data.Abstract.Package where
import Data.Abstract.FreeVariables
import Data.Abstract.Module
import Data.Abstract.ModuleTable as ModuleTable
import qualified Data.Map as Map
type PackageName = Name
@ -18,6 +20,7 @@ newtype Version = Version { versionString :: String }
data PackageBody term = PackageBody
{ packageModules :: ModuleTable [Module term]
, packagePrelude :: Maybe (Module term)
, packageEntryPoints :: ModuleTable (Maybe Name)
}
deriving (Eq, Functor, Ord, Show)
@ -30,11 +33,8 @@ data Package term = Package
}
deriving (Eq, Functor, Ord, Show)
fromModules :: [Module term] -> PackageBody term
fromModules [] = PackageBody mempty mempty
fromModules (m:ms) = fromModulesWithEntryPoint (m : ms) (modulePath (moduleInfo m))
fromModulesWithEntryPoint :: [Module term] -> FilePath -> PackageBody term
fromModulesWithEntryPoint ms path = PackageBody (ModuleTable.fromModules ms) entryPoints
where entryPoints = ModuleTable.singleton path Nothing
fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Package term
fromModules name version prelude entryPoints modules =
Package (PackageInfo name version) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints')
where
entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules

21
src/Data/Abstract/Path.hs
View File

@ -3,17 +3,24 @@ module Data.Abstract.Path where
import Prologue
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString as B
import System.FilePath.Posix
splitOnPathSeparator :: ByteString -> [ByteString]
splitOnPathSeparator = BC.split '/'
-- | 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 :: FilePath -> FilePath -> FilePath
joinPaths a b = let bs = splitPath (normalise b)
n = length (filter (== "../") bs)
in normalise $ walkup n a </> joinPath (drop n bs)
where
walkup 0 str = str
walkup n str = walkup (pred n) (takeDirectory str)
stripQuotes :: ByteString -> ByteString
stripQuotes = B.filter (`B.notElem` "\'\"")
dropRelativePrefix :: ByteString -> ByteString
dropRelativePrefix = BC.dropWhile (== '/') . BC.dropWhile (== '.')
dropExtension :: ByteString -> ByteString
dropExtension path = case BC.split '.' path of
[] -> path
xs -> BC.intercalate "." (Prelude.init xs)

96
src/Data/Abstract/Type.hs
View File

@ -1,13 +1,18 @@
{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
module Data.Abstract.Type where
{-# LANGUAGE GADTs, TypeFamilies, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the MonadValue instance, which requires MonadEvaluator to resolve its functional dependency.
module Data.Abstract.Type
( Type (..)
, TypeError (..)
, unify
) where
import Control.Abstract.Analysis
import Data.Abstract.Address
import Data.Abstract.Environment as Env
import Data.Align (alignWith)
import Data.Semigroup.Reducer (Reducer)
import Prelude hiding (fail)
import Prologue
import Prelude
import Prologue hiding (TypeError)
type TName = Int
@ -27,13 +32,33 @@ data Type
| 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)
-- TODO: À la carte representation of types.
data TypeError resume where
NumOpError :: Type -> Type -> TypeError Type
BitOpError :: Type -> Type -> TypeError Type
UnificationError :: Type -> Type -> TypeError Type
SubscriptError :: Type -> Type -> TypeError Type
deriving instance Show (TypeError resume)
instance Show1 TypeError where
liftShowsPrec _ _ _ (NumOpError l r) = showString "NumOpError " . shows [l, r]
liftShowsPrec _ _ _ (BitOpError l r) = showString "BitOpError " . shows [l, r]
liftShowsPrec _ _ _ (UnificationError l r) = showString "UnificationError " . shows [l, r]
liftShowsPrec _ _ _ (SubscriptError l r) = showString "SubscriptError " . shows [l, r]
instance Eq1 TypeError where
liftEq _ (BitOpError a b) (BitOpError c d) = a == c && b == d
liftEq _ (NumOpError a b) (NumOpError c d) = a == c && b == d
liftEq _ (UnificationError a b) (UnificationError c d) = a == c && b == d
liftEq _ _ _ = False
-- | Unify two 'Type's.
unify :: MonadFail m => Type -> Type -> m Type
unify :: (Effectful m, Applicative (m effects), Member (Resumable TypeError) effects) => Type -> Type -> m effects Type
unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2
unify a Null = pure a
unify Null b = pure b
@ -43,31 +68,32 @@ unify a (Var _) = pure a
unify (Product as) (Product bs) = Product <$> sequenceA (alignWith (these pure pure unify) as bs)
unify t1 t2
| t1 == t2 = pure t2
| otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2)
| otherwise = throwResumable (UnificationError t1 t2)
instance Ord location => ValueRoots location Type where
valueRoots _ = mempty
instance AbstractHole Type where
hole = Hole
-- | Discard the value arguments (if any), constructing a 'Type' instead.
instance ( Alternative m
, MonadAddressable location m
, MonadEnvironment location Type m
, MonadFail m
, MonadFresh m
, MonadHeap location Type m
instance ( Alternative (m effects)
, Member Fresh effects
, Member (Resumable TypeError) effects
, MonadAddressable location effects m
, MonadEvaluator location term Type effects m
, Reducer Type (Cell location Type)
)
=> MonadValue location Type m where
=> MonadValue location Type effects m where
lambda names (Subterm _ body) = do
(env, tvars) <- foldr (\ name rest -> do
a <- alloc name
tvar <- Var <$> fresh
tvar <- Var <$> raise fresh
assign a tvar
(env, tvars) <- rest
pure (Env.insert name a env, tvar : tvars)) (pure mempty) names
ret <- localEnv (mappend env) body
pure (Env.insert name a env, tvar : tvars)) (pure (emptyEnv, [])) names
ret <- localEnv (mergeEnvs env) body
pure (Product tvars :-> ret)
unit = pure Unit
@ -87,28 +113,37 @@ instance ( Alternative m
klass _ _ _ = pure Object
namespace _ _ = pure Unit
scopedEnvironment _ = pure mempty
scopedEnvironment _ = pure (Just emptyEnv)
asString _ = fail "Must evaluate to Value to use asString"
asPair _ = fail "Must evaluate to Value to use asPair"
asBool _ = fail "Must evaluate to Value to use asBool"
asString t = unify t String $> ""
asPair t = do
t1 <- raise fresh
t2 <- raise fresh
unify t (Product [Var t1, Var t2]) $> (Var t1, Var t2)
asBool t = unify t Bool *> (pure True <|> pure False)
isHole ty = pure (ty == Hole)
index (Array (mem:_)) Int = pure mem
index (Product (mem:_)) Int = pure mem
index a b = throwResumable (SubscriptError a b)
ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
liftNumeric _ Float = pure Float
liftNumeric _ Float = pure Float
liftNumeric _ Int = pure Int
liftNumeric _ _ = fail "Invalid type in unary numeric operation"
liftNumeric _ t = throwResumable (NumOpError t Hole)
liftNumeric2 _ left right = case (left, right) of
(Float, Int) -> pure Float
(Int, Float) -> pure Float
_ -> unify left right
_ -> unify left right
liftBitwise _ Int = pure Int
liftBitwise _ t = fail ("Invalid type passed to unary bitwise operation: " <> show t)
liftBitwise _ t = throwResumable (BitOpError t Hole)
liftBitwise2 _ Int Int = pure Int
liftBitwise2 _ t1 t2 = fail ("Invalid types passed to binary bitwise operation: " <> show (t1, t2))
liftBitwise2 _ t1 t2 = throwResumable (BitOpError t1 t2)
liftComparison (Concrete _) left right = case (left, right) of
(Float, Int) -> pure Bool
@ -120,9 +155,12 @@ instance ( Alternative m
_ -> unify left right $> Bool
call op params = do
tvar <- fresh
tvar <- raise fresh
paramTypes <- sequenceA params
_ :-> ret <- op `unify` (Product paramTypes :-> Var tvar)
pure ret
let needed = Product paramTypes :-> Var tvar
unified <- op `unify` needed
case unified of
_ :-> ret -> pure ret
gotten -> throwResumable (UnificationError needed gotten)
loop f = f empty

195
src/Data/Abstract/Value.hs
View File

@ -1,15 +1,24 @@
{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
{-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Data.Abstract.Value where
import Control.Abstract.Analysis
import Data.Abstract.Environment (Environment)
import Control.Abstract.Addressable
import Control.Abstract.Evaluator
import Control.Abstract.Value
import Control.Effect
import Control.Monad.Effect.Fail
import Control.Monad.Effect.Resumable
import Data.Abstract.Address
import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs)
import qualified Data.Abstract.Environment as Env
import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables
import qualified Data.Abstract.Number as Number
import Data.List (genericIndex, genericLength)
import Data.Scientific (Scientific)
import Data.Scientific.Exts
import Data.Semigroup.Reducer
import qualified Data.Set as Set
import Prologue hiding (TypeError)
import Prelude hiding (Float, Integer, String, Rational, fail)
import Prelude hiding (Float, Integer, String, Rational)
import qualified Prelude
type ValueConstructors location
@ -28,6 +37,7 @@ type ValueConstructors location
, Symbol
, Tuple
, Unit
, Hole
]
-- | Open union of primitive values that terms can be evaluated to.
@ -67,6 +77,13 @@ instance Eq1 Unit where liftEq = genericLiftEq
instance Ord1 Unit where liftCompare = genericLiftCompare
instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec
data Hole value = Hole
deriving (Eq, Generic1, Ord, Show)
instance Eq1 Hole where liftEq = genericLiftEq
instance Ord1 Hole where liftCompare = genericLiftCompare
instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec
-- | Boolean values.
newtype Boolean value = Boolean Prelude.Bool
deriving (Eq, Generic1, Ord, Show)
@ -189,8 +206,24 @@ instance Ord location => ValueRoots location (Value location) where
| otherwise = mempty
instance AbstractHole (Value location) where
hole = injValue Hole
-- | Construct a 'Value' wrapping the value arguments (if any).
instance forall location term m. (Monad m, MonadEvaluatable location term (Value location) m) => MonadValue location (Value location) m where
instance ( Member (EvalClosure term (Value location)) effects
, Member Fail effects
, Member (LoopControl (Value location)) effects
, Member (Resumable (AddressError location (Value location))) effects
, Member (Resumable (ValueError location (Value location))) effects
, Member (Return (Value location)) effects
, Monad (m effects)
, MonadAddressable location effects m
, MonadEvaluator location term (Value location) effects m
, Recursive term
, Reducer (Value location) (Cell location (Value location))
, Show location
)
=> MonadValue location (Value location) effects m where
unit = pure . injValue $ Unit
integer = pure . injValue . Integer . Number.Integer
boolean = pure . injValue . Boolean
@ -206,66 +239,83 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value
null = pure . injValue $ Null
asPair k
| Just (KVPair k v) <- prjValue k = pure (k, v)
| otherwise = fail ("expected key-value pair, got " <> show k)
asPair val
| Just (KVPair k v) <- prjValue val = pure (k, v)
| otherwise = throwResumable @(ValueError location (Value location)) $ KeyValueError val
hash = pure . injValue . Hash . fmap (injValue . uncurry KVPair)
klass n [] env = pure . injValue $ Class n env
klass n supers env = do
product <- mconcat <$> traverse scopedEnvironment supers
pure . injValue $ Class n (Env.push product <> env)
product <- foldl mergeEnvs emptyEnv . catMaybes <$> traverse scopedEnvironment supers
pure . injValue $ Class n (mergeEnvs product env)
namespace n env = do
maybeAddr <- lookupEnv n
env' <- maybe (pure mempty) (asNamespaceEnv <=< deref) maybeAddr
env' <- maybe (pure emptyEnv) (asNamespaceEnv <=< deref) maybeAddr
pure (injValue (Namespace n (Env.mergeNewer env' env)))
where asNamespaceEnv v
| Just (Namespace _ env') <- prjValue v = pure env'
| otherwise = throwException $ NamespaceError ("expected " <> show v <> " to be a namespace")
| otherwise = throwResumable $ NamespaceError ("expected " <> show v <> " to be a namespace")
scopedEnvironment o
| Just (Class _ env) <- prjValue o = pure env
| Just (Namespace _ env) <- prjValue o = pure env
| otherwise = throwException $ ScopedEnvironmentError ("object type passed to scopedEnvironment doesn't have an environment: " <> show o)
| Just (Class _ env) <- prjValue o = pure (Just env)
| Just (Namespace _ env) <- prjValue o = pure (Just env)
| otherwise = pure Nothing
asString v
| Just (String n) <- prjValue v = pure n
| otherwise = throwException @(ValueError location (Value location)) $ StringError v
| otherwise = throwResumable @(ValueError location (Value location)) $ StringError v
ifthenelse cond if' else' = do
bool <- asBool cond
if bool then if' else else'
isHole <- isHole cond
if isHole then
pure hole
else do
bool <- asBool cond
if bool then if' else else'
asBool val
| Just (Boolean b) <- prjValue val = pure b
| otherwise = throwException @(ValueError location (Value location)) $ BoolError val
| otherwise = throwResumable @(ValueError location (Value location)) $ BoolError val
isHole val = pure (prjValue val == Just Hole)
index = go where
tryIdx list ii
| ii > genericLength list = throwValueError (BoundsError list ii)
| otherwise = pure (genericIndex list ii)
go arr idx
| (Just (Array arr, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx arr i
| (Just (Tuple tup, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx tup i
| otherwise = throwValueError (IndexError arr idx)
liftNumeric f arg
| Just (Integer (Number.Integer i)) <- prjValue arg = integer $ f i
| Just (Float (Number.Decimal d)) <- prjValue arg = float $ f d
| Just (Rational (Number.Ratio r)) <- prjValue arg = rational $ f r
| otherwise = fail ("Invalid operand to liftNumeric: " <> show arg)
| Just (Float (Number.Decimal d)) <- prjValue arg = float $ f d
| Just (Rational (Number.Ratio r)) <- prjValue arg = rational $ f r
| otherwise = throwValueError (NumericError arg)
liftNumeric2 f left right
| Just (Integer i, Integer j) <- prjPair pair = f i j & specialize
| Just (Integer i, Rational j) <- prjPair pair = f i j & specialize
| Just (Integer i, Float j) <- prjPair pair = f i j & specialize
| Just (Rational i, Integer j) <- prjPair pair = f i j & specialize
| Just (Rational i, Rational j) <- prjPair pair = f i j & specialize
| Just (Rational i, Float j) <- prjPair pair = f i j & specialize
| Just (Float i, Integer j) <- prjPair pair = f i j & specialize
| Just (Float i, Rational j) <- prjPair pair = f i j & specialize
| Just (Float i, Float j) <- prjPair pair = f i j & specialize
| Just (Integer i, Integer j) <- prjPair pair = tentative f i j & specialize
| Just (Integer i, Rational j) <- prjPair pair = tentative f i j & specialize
| Just (Integer i, Float j) <- prjPair pair = tentative f i j & specialize
| Just (Rational i, Integer j) <- prjPair pair = tentative f i j & specialize
| Just (Rational i, Rational j) <- prjPair pair = tentative f i j & specialize
| Just (Rational i, Float j) <- prjPair pair = tentative f i j & specialize
| Just (Float i, Integer j) <- prjPair pair = tentative f i j & specialize
| Just (Float i, Rational j) <- prjPair pair = tentative f i j & specialize
| Just (Float i, Float j) <- prjPair pair = tentative f i j & specialize
| otherwise = throwValueError (Numeric2Error left right)
where
tentative x i j = attemptUnsafeArithmetic (x i j)
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
specialize :: MonadValue location value m => Number.SomeNumber -> m value
specialize (Number.SomeNumber (Number.Integer i)) = integer i
specialize (Number.SomeNumber (Number.Ratio r)) = rational r
specialize (Number.SomeNumber (Number.Decimal d)) = float d
specialize :: Either ArithException Number.SomeNumber -> m effects (Value location)
specialize (Left exc) = throwValueError (ArithmeticError exc)
specialize (Right (Number.SomeNumber (Number.Integer i))) = integer i
specialize (Right (Number.SomeNumber (Number.Ratio r))) = rational r
specialize (Right (Number.SomeNumber (Number.Decimal d))) = float d
pair = (left, right)
liftComparison comparator left right
@ -276,11 +326,11 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value
| Just (String i, String j) <- prjPair pair = go i j
| Just (Boolean i, Boolean j) <- prjPair pair = go i j
| Just (Unit, Unit) <- prjPair pair = boolean True
| otherwise = fail ("Type error: invalid arguments to liftComparison: " <> show pair)
| 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, MonadValue location value m) => a -> a -> m value
go :: Ord a => a -> a -> m effects (Value location)
go l r = case comparator of
Concrete f -> boolean (f l r)
Generalized -> integer (orderingToInt (compare l r))
@ -294,11 +344,11 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value
liftBitwise operator target
| Just (Integer (Number.Integer i)) <- prjValue target = integer $ operator i
| otherwise = fail ("Type error: invalid unary bitwise operation on " <> show target)
| otherwise = throwValueError (BitwiseError target)
liftBitwise2 operator left right
| Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = integer $ operator i j
| otherwise = fail ("Type error: invalid binary bitwise operation on " <> show pair)
| otherwise = throwValueError (Bitwise2Error left right)
where pair = (left, right)
lambda names (Subterm body _) = do
@ -308,12 +358,61 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value
call op params = do
case prjValue op of
Just (Closure names label env) -> do
bindings <- foldr (\ (name, param) rest -> do
v <- param
a <- alloc name
assign a v
Env.insert name a <$> rest) (pure env) (zip names params)
localEnv (mappend bindings) (goto label >>= evaluateTerm)
Nothing -> throwException @(ValueError location (Value location)) (CallError op)
-- Evaluate the bindings and the body within a `goto` in order to
-- charge their origins to the closure's origin.
goto label $ \body -> do
bindings <- foldr (\ (name, param) rest -> do
v <- param
a <- alloc name
assign a v
Env.insert name a <$> rest) (pure env) (zip names params)
localEnv (mergeEnvs bindings) (evalClosure body)
Nothing -> throwValueError (CallError op)
where
evalClosure term = catchReturn @m @(Value location) (evaluateClosureBody term) (\ (Return value) -> pure value)
loop = fix
loop x = catchLoopControl @m @(Value location) (fix x) (\ control -> case control of
Break value -> pure value
Continue -> loop x)
-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
data ValueError location value resume where
StringError :: value -> ValueError location value ByteString
BoolError :: value -> ValueError location value Bool
IndexError :: value -> value -> ValueError location value value
NamespaceError :: Prelude.String -> ValueError location value (Environment location value)
CallError :: value -> ValueError location value value
NumericError :: value -> ValueError location value value
Numeric2Error :: value -> value -> ValueError location value value
ComparisonError :: value -> value -> ValueError location value value
BitwiseError :: value -> ValueError location value value
Bitwise2Error :: value -> value -> ValueError location value value
KeyValueError :: value -> ValueError location value (value, value)
-- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
ArithmeticError :: ArithException -> ValueError location value value
-- Out-of-bounds error
BoundsError :: [value] -> Prelude.Integer -> ValueError location value value
instance Eq value => Eq1 (ValueError location value) where
liftEq _ (StringError a) (StringError b) = a == b
liftEq _ (NamespaceError a) (NamespaceError 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 value) => Show (ValueError location value resume)
instance (Show value) => Show1 (ValueError location value) where
liftShowsPrec _ _ = showsPrec
throwValueError :: (Member (Resumable (ValueError location value)) effects, MonadEvaluator location term value effects m) => ValueError location value resume -> m effects resume
throwValueError = throwResumable

30
src/Data/File.hs Normal file
View File

@ -0,0 +1,30 @@
module Data.File where
import Data.ByteString.Char8 as BC (pack)
import Data.Language
import Prologue
import System.FilePath.Posix
data File = File
{ filePath :: FilePath
, fileLanguage :: Maybe Language
}
deriving (Eq, Ord, Show)
data Project = Project
{ projectRootDir :: FilePath
, projectFiles :: [File]
, projectLanguage :: Language
, projectEntryPoints :: [File]
}
deriving (Eq, Ord, Show)
file :: FilePath -> File
file path = File path (languageForFilePath path)
where languageForFilePath = languageForType . takeExtension
projectName :: Project -> ByteString
projectName = BC.pack . dropExtensions . takeFileName . projectRootDir
projectExtensions :: Project -> [String]
projectExtensions = extensionsForLanguage . projectLanguage

12
src/Data/Language.hs
View File

@ -26,7 +26,7 @@ languageForType mediaType = case mediaType of
".md" -> Just Markdown
".rb" -> Just Ruby
".go" -> Just Go
".js" -> Just TypeScript
".js" -> Just JavaScript
".ts" -> Just TypeScript
".tsx" -> Just TypeScript
".jsx" -> Just JSX
@ -34,3 +34,13 @@ languageForType mediaType = case mediaType of
".php" -> Just PHP
".phpt" -> Just PHP
_ -> Nothing
extensionsForLanguage :: Language -> [String]
extensionsForLanguage language = case language of
Go -> [".go"]
JavaScript -> [".js"]
PHP -> [".php"]
Python -> [".py"]
Ruby -> [".rb"]
TypeScript -> [".ts", ".tsx", ".d.tsx"]
_ -> []

3
src/Data/Map/Monoidal.hs
View File

@ -11,6 +11,7 @@ module Data.Map.Monoidal
import qualified Data.Map as Map
import Data.Semigroup.Reducer as Reducer
import Data.Semilattice.Lower
import Prelude hiding (lookup)
import Prologue hiding (Map)
@ -42,3 +43,5 @@ instance (Ord key, Reducer a value) => Reducer (key, a) (Map key value) where
unit (key, a) = Map (Map.singleton key (unit a))
cons (key, a) (Map m) = Map (Map.insertWith (<>) key (unit a) m)
snoc (Map m) (key, a) = Map (Map.insertWith (flip (<>)) key (unit a) m)
instance Lower (Map key value) where lowerBound = Map lowerBound

6
src/Data/Range.hs
View File

@ -7,9 +7,10 @@ module Data.Range
, subtractRange
) where
import Prologue
import Data.Aeson
import Data.JSON.Fields
import Data.Semilattice.Lower
import Prologue
-- | A half-open interval of integers, defined by start & end indices.
data Range = Range { start :: {-# UNPACK #-} !Int, end :: {-# UNPACK #-} !Int }
@ -51,3 +52,6 @@ instance Ord Range where
instance ToJSONFields Range where
toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]
instance Lower Range where
lowerBound = Range 0 0

10
src/Data/Record.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-}
module Data.Record where
import Prologue
import Data.Aeson
import Data.JSON.Fields
import Data.Kind
import Data.Semilattice.Lower
import Prologue
-- | A type-safe, extensible record structure.
-- |
@ -87,3 +88,10 @@ instance ToJSONFields (Record '[]) where
instance ToJSONFields (Record fs) => ToJSON (Record fs) where
toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields
instance (Lower h, Lower (Record t)) => Lower (Record (h ': t)) where
lowerBound = lowerBound :. lowerBound
instance Lower (Record '[]) where
lowerBound = Nil

21
src/Data/Scientific/Exts.hs
View File

@ -1,19 +1,21 @@
module Data.Scientific.Exts
( module Data.Scientific
, attemptUnsafeArithmetic
, parseScientific
) where
import Prelude hiding (filter, null, takeWhile)
import Control.Applicative
import Control.Monad
import Control.Exception as Exc (evaluate, try)
import Control.Monad hiding (fail)
import Data.Attoparsec.ByteString.Char8
import Data.ByteString.Char8 hiding (readInt, takeWhile)
import Data.Char (isOctDigit)
import Data.Scientific
import Data.Semigroup
import Numeric
import Prelude hiding (fail, filter, null, takeWhile)
import Prologue hiding (null)
import Text.Read (readMaybe)
import System.IO.Unsafe
parseScientific :: ByteString -> Either String Scientific
parseScientific = parseOnly parser
@ -38,9 +40,9 @@ parser = signed (choice [hex, oct, bin, dec]) where
-- The ending stanza. Note the explicit endOfInput call to ensure we haven't left any dangling input.
done = skipWhile (inClass "iIjJlL") *> endOfInput
-- Wrapper around readMaybe. Analogous to maybeFail in the Prologue, but no need to pull that in.
-- Wrapper around readMaybe.
attempt :: Read a => String -> Parser a
attempt str = maybe (fail ("No parse: " <> str)) pure (readMaybe str)
attempt str = maybeM (fail ("No parse: " <> str)) (readMaybe str)
-- Parse a hex value, leaning on the parser provided by Attoparsec.
hex = fromIntegral <$> (string "0x" *> hexadecimal @Integer)
@ -97,3 +99,10 @@ parser = signed (choice [hex, oct, bin, dec]) where
let trail = if null trailings then "0" else trailings
attempt (unpack (leads <> "." <> trail <> exponent))
-- | Attempt to evaluate the given term into WHNF. If doing so raises an 'ArithException', such as
-- 'ZeroDivisionError' or 'RatioZeroDenominator', 'Left' will be returned.
-- Hooray for uncatchable exceptions that bubble up from third-party code.
attemptUnsafeArithmetic :: a -> Either ArithException a
attemptUnsafeArithmetic = unsafePerformIO . Exc.try . evaluate
{-# NOINLINE attemptUnsafeArithmetic #-}

40
src/Data/Semilattice/Lower.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE DefaultSignatures #-}
module Data.Semilattice.Lower
( Lower (..)
) where
import Data.IntMap as IntMap
import Data.IntSet as IntSet
import Data.Map as Map
import Data.Set as Set
class Lower s where
-- | The greatest lower bound of @s@.
--
-- Laws:
--
-- If @s@ is 'Bounded', we require 'lowerBound' and 'minBound' to agree:
--
-- > lowerBound = minBound
--
-- If @s@ is a 'Join' semilattice, 'lowerBound' must be the identity of '(\/)':
--
-- > lowerBound \/ a = a
--
-- If @s@ is 'Ord'ered, 'lowerBound' must be at least as small as every terminating value:
--
-- > compare lowerBound a /= GT
lowerBound :: s
default lowerBound :: Bounded s => s
lowerBound = minBound
instance Lower b => Lower (a -> b) where lowerBound = const lowerBound
instance Lower (Maybe a) where lowerBound = Nothing
instance Lower [a] where lowerBound = []
-- containers
instance Lower (IntMap a) where lowerBound = IntMap.empty
instance Lower IntSet where lowerBound = IntSet.empty
instance Lower (Map k a) where lowerBound = Map.empty
instance Lower (Set a) where lowerBound = Set.empty

6
src/Data/Span.hs
View File

@ -9,10 +9,11 @@ module Data.Span
, emptySpan
) where
import Prologue
import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as A
import Data.JSON.Fields
import Data.Semilattice.Lower
import Prologue
-- | Source position information
data Pos = Pos
@ -56,3 +57,6 @@ instance A.FromJSON Span where
instance ToJSONFields Span where
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
instance Lower Span where
lowerBound = Span (Pos 1 1) (Pos 1 1)

23
src/Data/Syntax.hs
View File

@ -111,9 +111,11 @@ instance Evaluatable Identifier where
instance FreeVariables1 Identifier where
liftFreeVariables _ (Identifier x) = pure x
instance Declarations1 Identifier where
liftDeclaredName _ (Identifier x) = pure x
newtype Program a = Program [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Program where liftEq = genericLiftEq
instance Ord1 Program where liftCompare = genericLiftCompare
@ -124,7 +126,7 @@ instance Evaluatable Program where
-- | An accessibility modifier, e.g. private, public, protected, etc.
newtype AccessibilityModifier a = AccessibilityModifier ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 AccessibilityModifier where liftEq = genericLiftEq
instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
@ -137,7 +139,7 @@ instance Evaluatable AccessibilityModifier
--
-- 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Empty where liftEq _ _ _ = True
instance Ord1 Empty where liftCompare _ _ _ = EQ
@ -146,21 +148,10 @@ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
instance Evaluatable Empty where
eval _ = unit
-- | A parenthesized expression or statement. All the languages we target support this concept.
newtype Paren a = Paren a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
instance Eq1 Paren where liftEq = genericLiftEq
instance Ord1 Paren where liftCompare = genericLiftCompare
instance Show1 Paren where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Paren where
eval (Paren a) = subtermValue a
-- | Syntax representing a parsing or assignment error.
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Error where liftEq = genericLiftEq
instance Ord1 Error where liftCompare = genericLiftCompare
@ -191,7 +182,7 @@ instance Ord ErrorStack where
data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Diffable Context where
subalgorithmFor blur focus (Context n s) = Context <$> traverse blur n <*> focus s

2
src/Data/Syntax/Comment.hs
View File

@ -7,7 +7,7 @@ import Diffing.Algorithm
-- | An unnested comment (line or block).
newtype Comment a = Comment { commentContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Comment where liftEq = genericLiftEq
instance Ord1 Comment where liftCompare = genericLiftCompare

58
src/Data/Syntax/Declaration.hs
View File

@ -7,7 +7,7 @@ import Diffing.Algorithm
import Prologue
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Diffable Function where
equivalentBySubterm = Just . functionName
@ -27,9 +27,12 @@ instance Evaluatable Function where
pure v
where paramNames = foldMap (freeVariables . subterm)
instance Declarations a => Declarations (Function a) where
declaredName Function{..} = declaredName functionName
data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Diffable Method where
equivalentBySubterm = Just . methodName
@ -51,7 +54,7 @@ instance Evaluatable Method where
-- | A method signature in TypeScript or a method spec in Go.
data MethodSignature a = MethodSignature { _methodSignatureContext :: ![a], _methodSignatureName :: !a, _methodSignatureParameters :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 MethodSignature where liftEq = genericLiftEq
instance Ord1 MethodSignature where liftCompare = genericLiftCompare
@ -62,7 +65,7 @@ instance Evaluatable MethodSignature
newtype RequiredParameter a = RequiredParameter { requiredParameter :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 RequiredParameter where liftEq = genericLiftEq
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
@ -73,7 +76,7 @@ instance Evaluatable RequiredParameter
newtype OptionalParameter a = OptionalParameter { optionalParameter :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 OptionalParameter where liftEq = genericLiftEq
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
@ -88,7 +91,7 @@ instance Evaluatable OptionalParameter
-- 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 VariableDeclaration where liftEq = genericLiftEq
instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
@ -98,9 +101,15 @@ instance Evaluatable VariableDeclaration where
eval (VariableDeclaration []) = unit
eval (VariableDeclaration decs) = multiple =<< traverse subtermValue decs
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, interfaceDeclarationBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
@ -109,10 +118,13 @@ 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 }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 PublicFieldDefinition where liftEq = genericLiftEq
instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
@ -123,7 +135,7 @@ instance Evaluatable PublicFieldDefinition
data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Variable where liftEq = genericLiftEq
instance Ord1 Variable where liftCompare = genericLiftCompare
@ -133,7 +145,10 @@ instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Variable
data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Declarations a => Declarations (Class a) where
declaredName (Class _ name _ _) = declaredName name
instance Diffable Class where
equivalentBySubterm = Just . classIdentifier
@ -154,7 +169,7 @@ instance Evaluatable Class where
-- | A decorator in Python
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Decorator where liftEq = genericLiftEq
instance Ord1 Decorator where liftCompare = genericLiftCompare
@ -168,7 +183,7 @@ instance Evaluatable Decorator
-- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift.
data Datatype a = Datatype { datatypeName :: !a, datatypeConstructors :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCompare
@ -180,7 +195,7 @@ 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 { constructorName :: !a, constructorFields :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLiftCompare
@ -192,7 +207,7 @@ 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Comprehension where liftEq = genericLiftEq
instance Ord1 Comprehension where liftCompare = genericLiftCompare
@ -204,7 +219,7 @@ instance Evaluatable Comprehension
-- | A declared type (e.g. `a []int` in Go).
data Type a = Type { typeName :: !a, typeKind :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Type where liftEq = genericLiftEq
instance Ord1 Type where liftCompare = genericLiftCompare
@ -216,11 +231,20 @@ instance Evaluatable Type
-- | Type alias declarations in Javascript/Haskell, etc.
data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeAlias where liftEq = genericLiftEq
instance Ord1 TypeAlias where liftCompare = genericLiftCompare
instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for TypeAlias
instance Evaluatable TypeAlias
instance Evaluatable TypeAlias where
eval TypeAlias{..} = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable (subterm typeAliasIdentifier))
v <- subtermValue typeAliasKind
addr <- lookupOrAlloc name
assign addr v
modifyEnv (Env.insert name addr) $> v
instance Declarations a => Declarations (TypeAlias a) where
declaredName TypeAlias{..} = declaredName typeAliasIdentifier

19
src/Data/Syntax/Directive.hs Normal file
View File

@ -0,0 +1,19 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
module Data.Syntax.Directive where
import Data.Abstract.Evaluatable
import Data.Abstract.Module (ModuleInfo(..))
import qualified Data.ByteString.Char8 as BC
import Diffing.Algorithm
import Prologue
-- A file directive like the Ruby constant `__FILE__`.
data File a = File
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
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 . BC.pack . modulePath

68
src/Data/Syntax/Expression.hs
View File

@ -2,15 +2,14 @@
module Data.Syntax.Expression where
import Data.Abstract.Evaluatable
import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent)
import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
import Data.Fixed
import Diffing.Algorithm
import Prelude
import Prologue
import Prologue hiding (index)
-- | 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Call where liftEq = genericLiftEq
instance Ord1 Call where liftCompare = genericLiftCompare
@ -28,7 +27,7 @@ data Comparison a
| GreaterThanEqual !a !a
| Equal !a !a
| Comparison !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Comparison where liftEq = genericLiftEq
instance Ord1 Comparison where liftCompare = genericLiftCompare
@ -50,10 +49,11 @@ data Arithmetic a
| Minus !a !a
| Times !a !a
| DividedBy !a !a
| FloorDivision !a !a
| Modulo !a !a
| Power !a !a
| Negate !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Arithmetic where liftEq = genericLiftEq
instance Ord1 Arithmetic where liftCompare = genericLiftCompare
@ -61,19 +61,20 @@ instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Arithmetic where
eval = traverse subtermValue >=> go where
go (Plus a b) = liftNumeric2 add a b where add = liftReal (+)
go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-)
go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*)
go (DividedBy a b) = liftNumeric2 div' a b where div' = liftIntegralFrac div (/)
go (Modulo a b) = liftNumeric2 mod'' a b where mod'' = liftIntegralFrac mod mod'
go (Power a b) = liftNumeric2 liftedExponent a b
go (Negate a) = liftNumeric negate a
go (Plus a b) = liftNumeric2 add a b where add = liftReal (+)
go (Minus a b) = liftNumeric2 sub a b where sub = liftReal (-)
go (Times a b) = liftNumeric2 mul a b where mul = liftReal (*)
go (DividedBy a b) = liftNumeric2 div' a b where div' = liftIntegralFrac div (/)
go (Modulo a b) = liftNumeric2 mod'' a b where mod'' = liftIntegralFrac mod mod'
go (Power a b) = liftNumeric2 liftedExponent a b
go (Negate a) = liftNumeric negate a
go (FloorDivision a b) = liftNumeric2 liftedFloorDiv a b
-- | Regex matching operators (Ruby's =~ and ~!)
data Match a
= Matches !a !a
| NotMatches !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Match where liftEq = genericLiftEq
instance Ord1 Match where liftCompare = genericLiftCompare
@ -88,7 +89,7 @@ data Boolean a
| And !a !a
| Not !a
| XOr !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Boolean where liftEq = genericLiftEq
instance Ord1 Boolean where liftCompare = genericLiftCompare
@ -108,7 +109,7 @@ instance Evaluatable Boolean where
-- | Javascript delete operator
newtype Delete a = Delete a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Delete where liftEq = genericLiftEq
instance Ord1 Delete where liftCompare = genericLiftCompare
@ -120,7 +121,7 @@ instance Evaluatable Delete
-- | A sequence expression such as Javascript or C's comma operator.
data SequenceExpression a = SequenceExpression { _firstExpression :: !a, _secondExpression :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 SequenceExpression where liftEq = genericLiftEq
instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
@ -132,7 +133,7 @@ instance Evaluatable SequenceExpression
-- | Javascript void operator
newtype Void a = Void a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Void where liftEq = genericLiftEq
instance Ord1 Void where liftCompare = genericLiftCompare
@ -144,7 +145,7 @@ instance Evaluatable Void
-- | Javascript typeof operator
newtype Typeof a = Typeof a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Typeof where liftEq = genericLiftEq
instance Ord1 Typeof where liftCompare = genericLiftCompare
@ -163,7 +164,7 @@ data Bitwise a
| RShift !a !a
| UnsignedRShift !a !a
| Complement a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Bitwise where liftEq = genericLiftEq
instance Ord1 Bitwise where liftCompare = genericLiftCompare
@ -185,34 +186,35 @@ instance Evaluatable Bitwise where
-- | Member Access (e.g. a.b)
data MemberAccess a
= MemberAccess !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 MemberAccess where liftEq = genericLiftEq
instance Ord1 MemberAccess where liftCompare = genericLiftCompare
instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable MemberAccess where
eval (fmap subtermValue -> MemberAccess mem acc) = do
lhs <- mem >>= scopedEnvironment
localEnv (mappend lhs) acc
eval (fmap subtermValue -> MemberAccess mem acc) = evaluateInScopedEnv mem acc
-- | Subscript (e.g a[1])
data Subscript a
= Subscript !a ![a]
| Member !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Subscript where liftEq = genericLiftEq
instance Ord1 Subscript where liftCompare = genericLiftCompare
instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Subscript
instance Evaluatable Subscript
instance Evaluatable Subscript where
eval (Subscript l [r]) = join (index <$> subtermValue l <*> subtermValue r)
eval (Subscript _ _) = throwResumable (Unspecialized "Eval unspecialized for subscript with slices")
eval (Member _ _) = throwResumable (Unspecialized "Eval unspecialized for member access")
-- | 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Enumeration where liftEq = genericLiftEq
instance Ord1 Enumeration where liftCompare = genericLiftCompare
@ -224,7 +226,7 @@ instance Evaluatable Enumeration
-- | InstanceOf (e.g. a instanceof b in JavaScript
data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 InstanceOf where liftEq = genericLiftEq
instance Ord1 InstanceOf where liftCompare = genericLiftCompare
@ -236,7 +238,7 @@ instance Evaluatable InstanceOf
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
newtype ScopeResolution a = ScopeResolution [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ScopeResolution where liftEq = genericLiftEq
instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
@ -248,7 +250,7 @@ instance Evaluatable ScopeResolution
-- | A non-null expression such as Typescript or Swift's ! expression.
newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 NonNullExpression where liftEq = genericLiftEq
instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
@ -260,7 +262,7 @@ instance Evaluatable NonNullExpression
-- | An await expression in Javascript or C#.
newtype Await a = Await { awaitSubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Await where liftEq = genericLiftEq
instance Ord1 Await where liftCompare = genericLiftCompare
@ -272,7 +274,7 @@ instance Evaluatable Await
-- | An object constructor call in Javascript, Java, etc.
newtype New a = New { newSubject :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 New where liftEq = genericLiftEq
instance Ord1 New where liftCompare = genericLiftCompare
@ -283,7 +285,7 @@ instance Evaluatable New
-- | A cast expression to a specified type.
data Cast a = Cast { castSubject :: !a, castType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Cast where liftEq = genericLiftEq
instance Ord1 Cast where liftCompare = genericLiftCompare

54
src/Data/Syntax/Literal.hs
View File

@ -7,14 +7,14 @@ import Data.ByteString.Char8 (readInteger, unpack)
import qualified Data.ByteString.Char8 as B
import Data.Scientific.Exts
import Diffing.Algorithm
import Prelude hiding (Float, fail, null)
import Prelude hiding (Float, null)
import Prologue hiding (Set, hash, null)
import Text.Read (readMaybe)
-- Boolean
newtype Boolean a = Boolean Bool
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
true :: Boolean a
true = Boolean True
@ -34,7 +34,7 @@ instance Evaluatable Boolean where
-- | A literal integer of unspecified width. No particular base is implied.
newtype Integer a = Integer { integerContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare
@ -42,14 +42,15 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow
instance Evaluatable Data.Syntax.Literal.Integer where
-- TODO: This instance probably shouldn't have readInteger?
eval (Data.Syntax.Literal.Integer x) = integer (maybe 0 fst (readInteger x))
eval (Data.Syntax.Literal.Integer x) =
integer =<< maybeM (throwEvalError (IntegerFormatError x)) (fst <$> readInteger x)
-- TODO: Should IntegerLiteral hold an Integer instead of a ByteString?
-- TODO: Consider a Numeric datatype with FloatingPoint/Integral/etc constructors.
-- | A literal float of unspecified width.
newtype Float a = Float { floatContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
@ -57,28 +58,27 @@ instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsP
instance Evaluatable Data.Syntax.Literal.Float where
eval (Float s) =
case parseScientific s of
Right num -> float num
Left err -> fail ("Parse error: " <> err)
float =<< either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s)
-- Rational literals e.g. `2/3r`
newtype Rational a = Rational ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
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 = B.takeWhile (/= 'r') r in
case readMaybe @Prelude.Integer (unpack trimmed) of
Just i -> rational (toRational i)
Nothing -> fail ("Bug: invalid rational " <> show r)
eval (Rational r) =
let
trimmed = B.takeWhile (/= 'r') r
parsed = readMaybe @Prelude.Integer (unpack trimmed)
in rational =<< maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed
-- Complex literals e.g. `3 + 2i`
newtype Complex a = Complex ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.Complex where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Complex where liftCompare = genericLiftCompare
@ -90,7 +90,7 @@ instance Evaluatable Complex
-- Strings, symbols
newtype String a = String { stringElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.String where liftCompare = genericLiftCompare
@ -104,7 +104,7 @@ instance Evaluatable Data.Syntax.Literal.String
-- | An interpolation element within a string literal.
newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 InterpolationElement where liftEq = genericLiftEq
instance Ord1 InterpolationElement where liftCompare = genericLiftCompare
@ -116,7 +116,7 @@ instance Evaluatable InterpolationElement
-- | A sequence of textual contents within a string literal.
newtype TextElement a = TextElement { textElementContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TextElement where liftEq = genericLiftEq
instance Ord1 TextElement where liftCompare = genericLiftCompare
@ -126,7 +126,7 @@ instance Evaluatable TextElement where
eval (TextElement x) = string x
data Null a = Null
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Null where liftEq = genericLiftEq
instance Ord1 Null where liftCompare = genericLiftCompare
@ -135,7 +135,7 @@ instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Null where eval = const null
newtype Symbol a = Symbol { symbolContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Symbol where liftEq = genericLiftEq
instance Ord1 Symbol where liftCompare = genericLiftCompare
@ -145,7 +145,7 @@ instance Evaluatable Symbol where
eval (Symbol s) = symbol s
newtype Regex a = Regex { regexContent :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Regex where liftEq = genericLiftEq
instance Ord1 Regex where liftCompare = genericLiftCompare
@ -161,7 +161,7 @@ instance Evaluatable Regex
-- Collections
newtype Array a = Array { arrayElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Array where liftEq = genericLiftEq
instance Ord1 Array where liftCompare = genericLiftCompare
@ -171,7 +171,7 @@ instance Evaluatable Array where
eval (Array a) = array =<< traverse subtermValue a
newtype Hash a = Hash { hashElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Hash where liftEq = genericLiftEq
instance Ord1 Hash where liftCompare = genericLiftCompare
@ -181,7 +181,7 @@ instance Evaluatable Hash where
eval = hashElements >>> traverse (subtermValue >=> asPair) >=> hash
data KeyValue a = KeyValue { key :: !a, value :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 KeyValue where liftEq = genericLiftEq
instance Ord1 KeyValue where liftCompare = genericLiftCompare
@ -192,7 +192,7 @@ instance Evaluatable KeyValue where
join (kvPair <$> key <*> value)
newtype Tuple a = Tuple { tupleContents :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Tuple where liftEq = genericLiftEq
instance Ord1 Tuple where liftCompare = genericLiftCompare
@ -202,7 +202,7 @@ instance Evaluatable Tuple where
eval (Tuple cs) = multiple =<< traverse subtermValue cs
newtype Set a = Set { setElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Set where liftEq = genericLiftEq
instance Ord1 Set where liftCompare = genericLiftCompare
@ -216,7 +216,7 @@ instance Evaluatable Set
-- | A declared pointer (e.g. var pointer *int in Go)
newtype Pointer a = Pointer a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Pointer where liftEq = genericLiftEq
instance Ord1 Pointer where liftCompare = genericLiftCompare
@ -228,7 +228,7 @@ instance Evaluatable Pointer
-- | A reference to a pointer's address (e.g. &pointer in Go)
newtype Reference a = Reference a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Reference where liftEq = genericLiftEq
instance Ord1 Reference where liftCompare = genericLiftCompare

83
src/Data/Syntax/Statement.hs
View File

@ -9,7 +9,7 @@ import Prologue
-- | 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 If where liftEq = genericLiftEq
instance Ord1 If where liftCompare = genericLiftCompare
@ -22,7 +22,7 @@ instance Evaluatable If where
-- | 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Else where liftEq = genericLiftEq
instance Ord1 Else where liftCompare = genericLiftCompare
@ -35,7 +35,7 @@ instance Evaluatable Else
-- | Goto statement (e.g. `goto a` in Go).
newtype Goto a = Goto { gotoLocation :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Goto where liftEq = genericLiftEq
instance Ord1 Goto where liftCompare = genericLiftCompare
@ -47,7 +47,7 @@ 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Match where liftEq = genericLiftEq
instance Ord1 Match where liftCompare = genericLiftCompare
@ -59,7 +59,7 @@ 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 { _pattern :: !a, patternBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Pattern where liftEq = genericLiftEq
instance Ord1 Pattern where liftCompare = genericLiftCompare
@ -71,7 +71,7 @@ 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Let where liftEq = genericLiftEq
instance Ord1 Let where liftCompare = genericLiftCompare
@ -88,7 +88,7 @@ instance Evaluatable Let where
-- | Assignment to a variable or other lvalue.
data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Assignment where liftEq = genericLiftEq
instance Ord1 Assignment where liftCompare = genericLiftCompare
@ -96,12 +96,17 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Assignment where
eval Assignment{..} = do
lhs <- subtermValue assignmentTarget >>= scopedEnvironment
localEnv (mappend lhs) (subtermValue assignmentValue)
case freeVariables (subterm assignmentTarget) of
[name] -> do
v <- subtermValue assignmentValue
addr <- lookupOrAlloc name
assign addr v
modifyEnv (Env.insert name addr) $> v
_ -> evaluateInScopedEnv (subtermValue assignmentTarget) (subtermValue assignmentValue)
-- | Post increment operator (e.g. 1++ in Go, or i++ in C).
newtype PostIncrement a = PostIncrement a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 PostIncrement where liftEq = genericLiftEq
instance Ord1 PostIncrement where liftCompare = genericLiftCompare
@ -113,7 +118,7 @@ instance Evaluatable PostIncrement
-- | Post decrement operator (e.g. 1-- in Go, or i-- in C).
newtype PostDecrement a = PostDecrement a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 PostDecrement where liftEq = genericLiftEq
instance Ord1 PostDecrement where liftCompare = genericLiftCompare
@ -149,17 +154,17 @@ instance Evaluatable PreDecrement
-- Returns
newtype Return a = Return a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Return where liftEq = genericLiftEq
instance Ord1 Return where liftCompare = genericLiftCompare
instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Return where
eval (Return x) = subtermValue x
eval (Return x) = subtermValue x >>= earlyReturn
newtype Yield a = Yield a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Yield where liftEq = genericLiftEq
instance Ord1 Yield where liftCompare = genericLiftCompare
@ -170,29 +175,28 @@ instance Evaluatable Yield
newtype Break a = Break a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Break where liftEq = genericLiftEq
instance Ord1 Break where liftCompare = genericLiftCompare
instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Break
instance Evaluatable Break
instance Evaluatable Break where
eval (Break x) = subtermValue x >>= throwBreak
newtype Continue a = Continue a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Continue where liftEq = genericLiftEq
instance Ord1 Continue where liftCompare = genericLiftCompare
instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for Continue
instance Evaluatable Continue
instance Evaluatable Continue where
-- TODO: figure out what to do with the datum inside Continue. what can it represent?
eval (Continue _) = throwContinue
newtype Retry a = Retry a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Retry where liftEq = genericLiftEq
instance Ord1 Retry where liftCompare = genericLiftCompare
@ -203,7 +207,7 @@ instance Evaluatable Retry
newtype NoOp a = NoOp a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 NoOp where liftEq = genericLiftEq
instance Ord1 NoOp where liftCompare = genericLiftCompare
@ -215,7 +219,7 @@ instance Evaluatable NoOp where
-- Loops
data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 For where liftEq = genericLiftEq
instance Ord1 For where liftCompare = genericLiftCompare
@ -226,7 +230,7 @@ instance Evaluatable For where
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ForEach where liftEq = genericLiftEq
instance Ord1 ForEach where liftCompare = genericLiftCompare
@ -237,7 +241,7 @@ instance Evaluatable ForEach
data While a = While { whileCondition :: !a, whileBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 While where liftEq = genericLiftEq
instance Ord1 While where liftCompare = genericLiftCompare
@ -247,7 +251,7 @@ instance Evaluatable While where
eval While{..} = while (subtermValue whileCondition) (subtermValue whileBody)
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 DoWhile where liftEq = genericLiftEq
instance Ord1 DoWhile where liftCompare = genericLiftCompare
@ -259,7 +263,7 @@ instance Evaluatable DoWhile where
-- Exception handling
newtype Throw a = Throw a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Throw where liftEq = genericLiftEq
instance Ord1 Throw where liftCompare = genericLiftCompare
@ -270,7 +274,7 @@ instance Evaluatable Throw
data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Try where liftEq = genericLiftEq
instance Ord1 Try where liftCompare = genericLiftCompare
@ -281,7 +285,7 @@ instance Evaluatable Try
data Catch a = Catch { catchException :: !a, catchBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Catch where liftEq = genericLiftEq
instance Ord1 Catch where liftCompare = genericLiftCompare
@ -292,7 +296,7 @@ instance Evaluatable Catch
newtype Finally a = Finally a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Finally where liftEq = genericLiftEq
instance Ord1 Finally where liftCompare = genericLiftCompare
@ -306,7 +310,7 @@ instance Evaluatable Finally
-- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl).
newtype ScopeEntry a = ScopeEntry [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ScopeEntry where liftEq = genericLiftEq
instance Ord1 ScopeEntry where liftCompare = genericLiftCompare
@ -318,7 +322,7 @@ instance Evaluatable ScopeEntry
-- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
newtype ScopeExit a = ScopeExit [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ScopeExit where liftEq = genericLiftEq
instance Ord1 ScopeExit where liftCompare = genericLiftCompare
@ -326,3 +330,14 @@ instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec
-- TODO: Implement Eval instance for ScopeExit
instance Evaluatable ScopeExit
-- | HashBang line (e.g. `#!/usr/bin/env node`)
newtype HashBang a = HashBang ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, 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

22
src/Data/Syntax/Type.hs
View File

@ -7,7 +7,7 @@ import Prelude hiding (Int, Float, Bool)
import Prologue hiding (Map)
data Array a = Array { arraySize :: Maybe a, arrayElementType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Array where liftEq = genericLiftEq
instance Ord1 Array where liftCompare = genericLiftCompare
@ -19,7 +19,7 @@ instance Evaluatable Array
-- TODO: What about type variables? re: FreeVariables1
data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Annotation where liftEq = genericLiftEq
instance Ord1 Annotation where liftCompare = genericLiftCompare
@ -31,7 +31,7 @@ instance Evaluatable Annotation where
data Function a = Function { functionParameters :: [a], functionReturn :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Function where liftEq = genericLiftEq
instance Ord1 Function where liftCompare = genericLiftCompare
@ -42,7 +42,7 @@ instance Evaluatable Function
newtype Interface a = Interface [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Interface where liftEq = genericLiftEq
instance Ord1 Interface where liftCompare = genericLiftCompare
@ -53,7 +53,7 @@ instance Evaluatable Interface
data Map a = Map { mapKeyType :: a, mapElementType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Map where liftEq = genericLiftEq
instance Ord1 Map where liftCompare = genericLiftCompare
@ -64,7 +64,7 @@ instance Evaluatable Map
newtype Parenthesized a = Parenthesized a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Parenthesized where liftEq = genericLiftEq
instance Ord1 Parenthesized where liftCompare = genericLiftCompare
@ -75,7 +75,7 @@ instance Evaluatable Parenthesized
newtype Pointer a = Pointer a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Pointer where liftEq = genericLiftEq
instance Ord1 Pointer where liftCompare = genericLiftCompare
@ -86,7 +86,7 @@ instance Evaluatable Pointer
newtype Product a = Product [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Product where liftEq = genericLiftEq
instance Ord1 Product where liftCompare = genericLiftCompare
@ -97,7 +97,7 @@ instance Evaluatable Product
data Readonly a = Readonly
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Readonly where liftEq = genericLiftEq
instance Ord1 Readonly where liftCompare = genericLiftCompare
@ -108,7 +108,7 @@ instance Evaluatable Readonly
newtype Slice a = Slice a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Slice where liftEq = genericLiftEq
instance Ord1 Slice where liftCompare = genericLiftCompare
@ -119,7 +119,7 @@ instance Evaluatable Slice
newtype TypeParameters a = TypeParameters [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeParameters where liftEq = genericLiftEq
instance Ord1 TypeParameters where liftCompare = genericLiftCompare

3
src/Language/Go/Assignment.hs
View File

@ -89,7 +89,6 @@ type Syntax =
, Syntax.Error
, Syntax.Empty
, Syntax.Identifier
, Syntax.Paren
, Syntax.Program
, Type.Annotation
, Type.Array
@ -429,7 +428,7 @@ parameterDeclaration :: Assignment
parameterDeclaration = makeTerm <$> symbol ParameterDeclaration <*> children (manyTerm expression)
parenthesizedExpression :: Assignment
parenthesizedExpression = makeTerm <$> symbol ParenthesizedExpression <*> (Syntax.Paren <$> children expressions)
parenthesizedExpression = symbol ParenthesizedExpression *> children expressions
selectorExpression :: Assignment
selectorExpression = makeTerm <$> symbol SelectorExpression <*> children (Expression.MemberAccess <$> expression <*> expression)

116
src/Language/Go/Syntax.hs
View File

@ -1,48 +1,66 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveAnyClass, ScopedTypeVariables #-}
module Language.Go.Syntax where
import Data.Abstract.Evaluatable hiding (Label)
import Data.Abstract.Module
import Data.Abstract.FreeVariables (name)
import Diffing.Algorithm
import qualified Data.ByteString.Char8 as BC
import Data.Abstract.Evaluatable hiding (Label)
import Data.Abstract.FreeVariables (Name (..), name)
import Data.Abstract.Module
import qualified Data.Abstract.Package as Package
import Data.Abstract.Path
import qualified Data.ByteString as B
import System.FilePath.Posix
import Prologue
import qualified Data.ByteString.Char8 as BC
import Diffing.Algorithm
import Prologue
import System.FilePath.Posix
newtype ImportPath = ImportPath { unPath :: FilePath }
data Relative = Relative | NonRelative
deriving (Eq, Ord, Show)
data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: Relative }
deriving (Eq, Ord, Show)
importPath :: ByteString -> ImportPath
importPath str = let path = stripQuotes str in ImportPath (BC.unpack path)
where stripQuotes = B.filter (`B.notElem` "\'\"")
importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (pathType path)
where
stripQuotes = B.filter (`B.notElem` "\'\"")
pathType xs | not (B.null xs), BC.head xs == '.' = Relative
| otherwise = NonRelative
defaultAlias :: ImportPath -> Name
defaultAlias = name . BC.pack . takeFileName . unPath
-- TODO: need to delineate between relative and absolute Go imports
resolveGoImport :: MonadEvaluatable location term value m => FilePath -> m [ModulePath]
resolveGoImport relImportPath = do
resolveGoImport :: forall value term location effects m. MonadEvaluatable location term value effects m => ImportPath -> m effects [ModulePath]
resolveGoImport (ImportPath path Relative) = do
ModuleInfo{..} <- currentModule
let relRootDir = takeDirectory (makeRelative moduleRoot modulePath)
listModulesInDir $ normalise (relRootDir </> normalise relImportPath)
paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path)
case paths of
[] -> throwResumable @(ResolutionError value) $ GoImportError path
_ -> pure paths
resolveGoImport (ImportPath path NonRelative) = do
package <- BC.unpack . unName . Package.packageName <$> currentPackage
traceM ("attempting to resolve " <> show path <> " for package " <> package)
case splitDirectories path of
-- Import an absolute path that's defined in this package being analyized.
-- First two are source, next is package name, remaining are path to package
-- (e.g. github.com/golang/<package>/path...).
(_ : _ : p : xs) | p == package -> listModulesInDir (joinPath xs)
_ -> throwResumable @(ResolutionError value) $ 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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Import where liftEq = genericLiftEq
instance Ord1 Import where liftCompare = genericLiftCompare
instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Import where
eval (Import (ImportPath name) _) = do
paths <- resolveGoImport name
eval (Import importPath _) = do
paths <- resolveGoImport importPath
for_ paths $ \path -> do
(importedEnv, _) <- isolate (require path)
modifyEnv (mappend importedEnv)
(importedEnv, _) <- traceResolve (unPath importPath) path $ isolate (require path)
modifyEnv (mergeEnvs importedEnv)
unit
@ -50,41 +68,41 @@ instance Evaluatable Import where
--
-- If the list of symbols is empty copy and qualify everything to the calling environment.
data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, qualifiedImportAlias :: !a}
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
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 name) aliasTerm) = do
paths <- resolveGoImport name
eval (QualifiedImport importPath aliasTerm) = do
paths <- resolveGoImport importPath
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
void $ letrec' alias $ \addr -> do
for_ paths $ \path -> do
(importedEnv, _) <- isolate (require path)
modifyEnv (mappend importedEnv)
(importedEnv, _) <- traceResolve (unPath importPath) path $ isolate (require path)
modifyEnv (mergeEnvs importedEnv)
makeNamespace alias addr []
makeNamespace alias addr Nothing
unit
-- | Side effect only imports (no symbols made available to the calling environment).
data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
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 name) _) = do
paths <- resolveGoImport name
for_ paths (isolate . require)
eval (SideEffectImport importPath _) = do
paths <- resolveGoImport importPath
for_ paths $ \path -> traceResolve (unPath importPath) path $ isolate (require path)
unit
-- A composite literal in Go
data Composite a = Composite { compositeType :: !a, compositeElement :: !a }
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Composite where liftEq = genericLiftEq
instance Ord1 Composite where liftCompare = genericLiftCompare
@ -95,7 +113,7 @@ 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 (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 DefaultPattern where liftEq = genericLiftEq
instance Ord1 DefaultPattern where liftCompare = genericLiftCompare
@ -106,7 +124,7 @@ instance Evaluatable DefaultPattern
-- | A defer statement in Go (e.g. `defer x()`).
newtype Defer a = Defer { deferBody :: a }
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Defer where liftEq = genericLiftEq
instance Ord1 Defer where liftCompare = genericLiftCompare
@ -117,7 +135,7 @@ instance Evaluatable Defer
-- | A go statement (i.e. go routine) in Go (e.g. `go x()`).
newtype Go a = Go { goBody :: a }
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Go where liftEq = genericLiftEq
instance Ord1 Go where liftCompare = genericLiftCompare
@ -128,7 +146,7 @@ instance Evaluatable Go
-- | A label statement in Go (e.g. `label:continue`).
data Label a = Label { _labelName :: !a, labelStatement :: !a }
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Label where liftEq = genericLiftEq
instance Ord1 Label where liftCompare = genericLiftCompare
@ -139,7 +157,7 @@ instance Evaluatable Label
-- | A rune literal in Go (e.g. `'⌘'`).
newtype Rune a = Rune { _runeLiteral :: ByteString }
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
-- TODO: Implement Eval instance for Rune
instance Evaluatable Rune
@ -150,7 +168,7 @@ instance Show1 Rune where liftShowsPrec = genericLiftShowsPrec
-- | 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 (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
-- TODO: Implement Eval instance for Select
instance Evaluatable Select
@ -161,7 +179,7 @@ instance Show1 Select where liftShowsPrec = genericLiftShowsPrec
-- | A send statement in Go (e.g. `channel <- value`).
data Send a = Send { sendReceiver :: !a, sendValue :: !a }
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Send where liftEq = genericLiftEq
instance Ord1 Send where liftCompare = genericLiftCompare
@ -172,7 +190,7 @@ 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 (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Slice where liftEq = genericLiftEq
instance Ord1 Slice where liftCompare = genericLiftCompare
@ -183,7 +201,7 @@ instance Evaluatable Slice
-- | A type switch statement in Go (e.g. `switch x.(type) { // cases }`).
data TypeSwitch a = TypeSwitch { typeSwitchSubject :: !a, typeSwitchCases :: !a }
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeSwitch where liftEq = genericLiftEq
instance Ord1 TypeSwitch where liftCompare = genericLiftCompare
@ -194,7 +212,7 @@ 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 (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeSwitchGuard where liftEq = genericLiftEq
instance Ord1 TypeSwitchGuard where liftCompare = genericLiftCompare
@ -205,7 +223,7 @@ 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 (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Receive where liftEq = genericLiftEq
instance Ord1 Receive where liftCompare = genericLiftCompare
@ -216,7 +234,7 @@ instance Evaluatable Receive
-- | A receive operator unary expression in Go (e.g. `<-channel` )
newtype ReceiveOperator a = ReceiveOperator a
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ReceiveOperator where liftEq = genericLiftEq
instance Ord1 ReceiveOperator where liftCompare = genericLiftCompare
@ -227,7 +245,7 @@ instance Evaluatable ReceiveOperator
-- | A field declaration in a Go struct type declaration.
data Field a = Field { fieldContext :: ![a], fieldName :: !a }
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Field where liftEq = genericLiftEq
instance Ord1 Field where liftCompare = genericLiftCompare
@ -238,7 +256,7 @@ instance Evaluatable Field
data Package a = Package { packageName :: !a, packageContents :: ![a] }
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Package where liftEq = genericLiftEq
instance Ord1 Package where liftCompare = genericLiftCompare
@ -250,7 +268,7 @@ instance Evaluatable Package where
-- | 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 (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeAssertion where liftEq = genericLiftEq
instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
@ -261,7 +279,7 @@ 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 (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeConversion where liftEq = genericLiftEq
instance Ord1 TypeConversion where liftCompare = genericLiftCompare
@ -272,7 +290,7 @@ 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 (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Variadic where liftEq = genericLiftEq
instance Ord1 Variadic where liftCompare = genericLiftCompare

6
src/Language/Go/Type.hs
View File

@ -7,7 +7,7 @@ import Diffing.Algorithm
-- | A Bidirectional channel in Go (e.g. `chan`).
newtype BidirectionalChannel a = BidirectionalChannel a
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 BidirectionalChannel where liftEq = genericLiftEq
instance Ord1 BidirectionalChannel where liftCompare = genericLiftCompare
@ -18,7 +18,7 @@ instance Evaluatable BidirectionalChannel
-- | A Receive channel in Go (e.g. `<-chan`).
newtype ReceiveChannel a = ReceiveChannel a
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ReceiveChannel where liftEq = genericLiftEq
instance Ord1 ReceiveChannel where liftCompare = genericLiftCompare
@ -29,7 +29,7 @@ instance Evaluatable ReceiveChannel
-- | A Send channel in Go (e.g. `chan<-`).
newtype SendChannel a = SendChannel a
deriving (Diffable, Eq, FreeVariables1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 SendChannel where liftEq = genericLiftEq
instance Ord1 SendChannel where liftCompare = genericLiftCompare

2
src/Language/JSON/Assignment.hs
View File

@ -23,10 +23,8 @@ type Syntax =
, Literal.Float
, Literal.KeyValue
, Literal.Null
, Literal.String
, Literal.TextElement
, Syntax.Error
, []
]
type Term = Term.Term (Union Syntax) (Record Location)

3
src/Language/PHP/Assignment.hs
View File

@ -103,7 +103,6 @@ type Syntax = '[
, Syntax.NamespaceUseDeclaration
, Syntax.NamespaceUseGroupClause
, Syntax.NewVariable
, Syntax.Paren
, Syntax.PrintIntrinsic
, Syntax.Program
, Syntax.PropertyDeclaration
@ -288,7 +287,7 @@ primaryExpression = choice [
]
parenthesizedExpression :: Assignment
parenthesizedExpression = makeTerm <$> symbol ParenthesizedExpression <*> (Syntax.Paren <$> children (term expression))
parenthesizedExpression = symbol ParenthesizedExpression *> children (term expression)
classConstantAccessExpression :: Assignment
classConstantAccessExpression = makeTerm <$> symbol ClassConstantAccessExpression <*> children (Expression.MemberAccess <$> term scopeResolutionQualifier <*> term name)

164
src/Language/PHP/Syntax.hs
View File

@ -1,16 +1,17 @@
{-# LANGUAGE DeriveAnyClass, ViewPatterns #-}
{-# LANGUAGE DeriveAnyClass, ViewPatterns, ScopedTypeVariables #-}
module Language.PHP.Syntax where
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import Data.Abstract.Path
import qualified Data.ByteString.Char8 as BC
import qualified Data.Language as Language
import Diffing.Algorithm
import Prelude hiding (fail)
import Prologue hiding (Text)
newtype Text a = Text ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Text where liftEq = genericLiftEq
instance Ord1 Text where liftCompare = genericLiftCompare
@ -19,7 +20,7 @@ instance Evaluatable Text
newtype VariableName a = VariableName a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 VariableName where liftEq = genericLiftEq
instance Ord1 VariableName where liftCompare = genericLiftCompare
@ -34,74 +35,70 @@ instance Evaluatable VariableName
-- file, the complete contents of the included file are treated as though it
-- were defined inside that function.
resolvePHPName :: MonadEvaluatable location term value m => ByteString -> m ModulePath
resolvePHPName n = resolve [name] >>= maybeFail notFound
resolvePHPName :: forall value location term effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
resolvePHPName n = do
modulePath <- resolve [name]
maybe (throwResumable @(ResolutionError value) $ NotFoundError name [name] Language.PHP) pure modulePath
where name = toName n
notFound = "Unable to resolve: " <> name
toName = BC.unpack . dropRelativePrefix . stripQuotes
doInclude :: MonadEvaluatable location term value m => Subterm t (m value) -> m value
doInclude pathTerm = do
include :: MonadEvaluatable location term value effects m
=> Subterm t (m effects value)
-> (ModulePath -> m effects (Environment location value, value))
-> m effects value
include pathTerm f = do
name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name
(importedEnv, v) <- isolate (load path)
modifyEnv (mappend importedEnv)
pure v
doIncludeOnce :: MonadEvaluatable location term value m => Subterm t (m value) -> m value
doIncludeOnce pathTerm = do
name <- subtermValue pathTerm >>= asString
path <- resolvePHPName name
(importedEnv, v) <- isolate (require path)
modifyEnv (mappend importedEnv)
(importedEnv, v) <- traceResolve name path $ isolate (f path)
modifyEnv (mergeEnvs importedEnv)
pure v
newtype Require a = Require a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Require where liftEq = genericLiftEq
instance Ord1 Require where liftCompare = genericLiftCompare
instance Show1 Require where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Require where
eval (Require path) = doInclude path
eval (Require path) = include path load
newtype RequireOnce a = RequireOnce a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 RequireOnce where liftEq = genericLiftEq
instance Ord1 RequireOnce where liftCompare = genericLiftCompare
instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RequireOnce where
eval (RequireOnce path) = doIncludeOnce path
eval (RequireOnce path) = include path require
newtype Include a = Include a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Include where liftEq = genericLiftEq
instance Ord1 Include where liftCompare = genericLiftCompare
instance Show1 Include where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Include where
eval (Include path) = doInclude path
eval (Include path) = include path load
newtype IncludeOnce a = IncludeOnce a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 IncludeOnce where liftEq = genericLiftEq
instance Ord1 IncludeOnce where liftCompare = genericLiftCompare
instance Show1 IncludeOnce where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IncludeOnce where
eval (IncludeOnce path) = doIncludeOnce path
eval (IncludeOnce path) = include path require
newtype ArrayElement a = ArrayElement a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ArrayElement where liftEq = genericLiftEq
instance Ord1 ArrayElement where liftCompare = genericLiftCompare
@ -109,7 +106,7 @@ instance Show1 ArrayElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ArrayElement
newtype GlobalDeclaration a = GlobalDeclaration [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 GlobalDeclaration where liftEq = genericLiftEq
instance Ord1 GlobalDeclaration where liftCompare = genericLiftCompare
@ -117,7 +114,7 @@ instance Show1 GlobalDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable GlobalDeclaration
newtype SimpleVariable a = SimpleVariable a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 SimpleVariable where liftEq = genericLiftEq
instance Ord1 SimpleVariable where liftCompare = genericLiftCompare
@ -127,7 +124,7 @@ instance Evaluatable SimpleVariable
-- | TODO: Unify with TypeScript's PredefinedType
newtype CastType a = CastType { _castType :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 CastType where liftEq = genericLiftEq
instance Ord1 CastType where liftCompare = genericLiftCompare
@ -135,7 +132,7 @@ instance Show1 CastType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable CastType
newtype ErrorControl a = ErrorControl a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ErrorControl where liftEq = genericLiftEq
instance Ord1 ErrorControl where liftCompare = genericLiftCompare
@ -143,7 +140,7 @@ instance Show1 ErrorControl where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ErrorControl
newtype Clone a = Clone a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Clone where liftEq = genericLiftEq
instance Ord1 Clone where liftCompare = genericLiftCompare
@ -151,7 +148,7 @@ instance Show1 Clone where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Clone
newtype ShellCommand a = ShellCommand ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ShellCommand where liftEq = genericLiftEq
instance Ord1 ShellCommand where liftCompare = genericLiftCompare
@ -160,7 +157,7 @@ instance Evaluatable ShellCommand
-- | TODO: Combine with TypeScript update expression.
newtype Update a = Update { _updateSubject :: a }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Update where liftEq = genericLiftEq
instance Ord1 Update where liftCompare = genericLiftCompare
@ -168,7 +165,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Update
newtype NewVariable a = NewVariable [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 NewVariable where liftEq = genericLiftEq
instance Ord1 NewVariable where liftCompare = genericLiftCompare
@ -176,7 +173,7 @@ instance Show1 NewVariable where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NewVariable
newtype RelativeScope a = RelativeScope ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 RelativeScope where liftEq = genericLiftEq
instance Ord1 RelativeScope where liftCompare = genericLiftCompare
@ -184,34 +181,27 @@ instance Show1 RelativeScope where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RelativeScope
data QualifiedName a = QualifiedName !a !a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 QualifiedName where liftEq = genericLiftEq
instance Ord1 QualifiedName where liftCompare = genericLiftCompare
instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedName where
eval (fmap subtermValue -> QualifiedName name iden) = do
lhs <- name >>= scopedEnvironment
localEnv (mappend lhs) iden
eval (fmap subtermValue -> QualifiedName name iden) = evaluateInScopedEnv name iden
newtype NamespaceName a = NamespaceName (NonEmpty a)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 NamespaceName where liftEq = genericLiftEq
instance Ord1 NamespaceName where liftCompare = genericLiftCompare
instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NamespaceName where
eval (NamespaceName xs) = foldl1 f $ fmap subtermValue xs
where
f ns nam = do
env <- ns >>= scopedEnvironment
localEnv (mappend env) nam
eval (NamespaceName xs) = foldl1 evaluateInScopedEnv $ fmap subtermValue xs
newtype ConstDeclaration a = ConstDeclaration [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ConstDeclaration where liftEq = genericLiftEq
instance Ord1 ConstDeclaration where liftCompare = genericLiftCompare
@ -219,7 +209,7 @@ instance Show1 ConstDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ConstDeclaration
data ClassConstDeclaration a = ClassConstDeclaration a [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ClassConstDeclaration where liftEq = genericLiftEq
instance Ord1 ClassConstDeclaration where liftCompare = genericLiftCompare
@ -227,7 +217,7 @@ instance Show1 ClassConstDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassConstDeclaration
newtype ClassInterfaceClause a = ClassInterfaceClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ClassInterfaceClause where liftEq = genericLiftEq
instance Ord1 ClassInterfaceClause where liftCompare = genericLiftCompare
@ -235,7 +225,7 @@ instance Show1 ClassInterfaceClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassInterfaceClause
newtype ClassBaseClause a = ClassBaseClause a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ClassBaseClause where liftEq = genericLiftEq
instance Ord1 ClassBaseClause where liftCompare = genericLiftCompare
@ -244,7 +234,7 @@ instance Evaluatable ClassBaseClause
newtype UseClause a = UseClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 UseClause where liftEq = genericLiftEq
instance Ord1 UseClause where liftCompare = genericLiftCompare
@ -252,7 +242,7 @@ instance Show1 UseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable UseClause
newtype ReturnType a = ReturnType a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ReturnType where liftEq = genericLiftEq
instance Ord1 ReturnType where liftCompare = genericLiftCompare
@ -260,7 +250,7 @@ instance Show1 ReturnType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ReturnType
newtype TypeDeclaration a = TypeDeclaration a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TypeDeclaration where liftEq = genericLiftEq
instance Ord1 TypeDeclaration where liftCompare = genericLiftCompare
@ -268,7 +258,7 @@ instance Show1 TypeDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeDeclaration
newtype BaseTypeDeclaration a = BaseTypeDeclaration a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 BaseTypeDeclaration where liftEq = genericLiftEq
instance Ord1 BaseTypeDeclaration where liftCompare = genericLiftCompare
@ -276,7 +266,7 @@ instance Show1 BaseTypeDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable BaseTypeDeclaration
newtype ScalarType a = ScalarType ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ScalarType where liftEq = genericLiftEq
instance Ord1 ScalarType where liftCompare = genericLiftCompare
@ -284,7 +274,7 @@ instance Show1 ScalarType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ScalarType
newtype EmptyIntrinsic a = EmptyIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 EmptyIntrinsic where liftEq = genericLiftEq
instance Ord1 EmptyIntrinsic where liftCompare = genericLiftCompare
@ -292,7 +282,7 @@ instance Show1 EmptyIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable EmptyIntrinsic
newtype ExitIntrinsic a = ExitIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ExitIntrinsic where liftEq = genericLiftEq
instance Ord1 ExitIntrinsic where liftCompare = genericLiftCompare
@ -300,7 +290,7 @@ instance Show1 ExitIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ExitIntrinsic
newtype IssetIntrinsic a = IssetIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 IssetIntrinsic where liftEq = genericLiftEq
instance Ord1 IssetIntrinsic where liftCompare = genericLiftCompare
@ -308,7 +298,7 @@ instance Show1 IssetIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IssetIntrinsic
newtype EvalIntrinsic a = EvalIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 EvalIntrinsic where liftEq = genericLiftEq
instance Ord1 EvalIntrinsic where liftCompare = genericLiftCompare
@ -316,7 +306,7 @@ instance Show1 EvalIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable EvalIntrinsic
newtype PrintIntrinsic a = PrintIntrinsic a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 PrintIntrinsic where liftEq = genericLiftEq
instance Ord1 PrintIntrinsic where liftCompare = genericLiftCompare
@ -324,7 +314,7 @@ instance Show1 PrintIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PrintIntrinsic
newtype NamespaceAliasingClause a = NamespaceAliasingClause a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 NamespaceAliasingClause where liftEq = genericLiftEq
instance Ord1 NamespaceAliasingClause where liftCompare = genericLiftCompare
@ -332,7 +322,7 @@ instance Show1 NamespaceAliasingClause where liftShowsPrec = genericLiftShowsPre
instance Evaluatable NamespaceAliasingClause
newtype NamespaceUseDeclaration a = NamespaceUseDeclaration [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 NamespaceUseDeclaration where liftEq = genericLiftEq
instance Ord1 NamespaceUseDeclaration where liftCompare = genericLiftCompare
@ -340,7 +330,7 @@ instance Show1 NamespaceUseDeclaration where liftShowsPrec = genericLiftShowsPre
instance Evaluatable NamespaceUseDeclaration
newtype NamespaceUseClause a = NamespaceUseClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 NamespaceUseClause where liftEq = genericLiftEq
instance Ord1 NamespaceUseClause where liftCompare = genericLiftCompare
@ -348,7 +338,7 @@ instance Show1 NamespaceUseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NamespaceUseClause
newtype NamespaceUseGroupClause a = NamespaceUseGroupClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 NamespaceUseGroupClause where liftEq = genericLiftEq
instance Ord1 NamespaceUseGroupClause where liftCompare = genericLiftCompare
@ -356,7 +346,7 @@ instance Show1 NamespaceUseGroupClause where liftShowsPrec = genericLiftShowsPre
instance Evaluatable NamespaceUseGroupClause
data Namespace a = Namespace { namespaceName :: a, namespaceBody :: a }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Namespace where liftEq = genericLiftEq
instance Ord1 Namespace where liftCompare = genericLiftCompare
@ -366,16 +356,16 @@ instance Evaluatable Namespace where
eval Namespace{..} = go names
where
names = freeVariables (subterm namespaceName)
go [] = fail "expected at least one free variable in namespaceName, found none"
go [] = raise (fail "expected at least one free variable in namespaceName, found none")
-- The last name creates a closure over the namespace body.
go [name] = letrec' name $ \addr ->
subtermValue namespaceBody *> makeNamespace name addr []
subtermValue namespaceBody *> makeNamespace name addr Nothing
-- Each namespace name creates a closure over the subsequent namespace closures
go (name:xs) = letrec' name $ \addr ->
go xs <* makeNamespace name addr []
go xs <* makeNamespace name addr Nothing
data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TraitDeclaration where liftEq = genericLiftEq
instance Ord1 TraitDeclaration where liftCompare = genericLiftCompare
@ -383,7 +373,7 @@ instance Show1 TraitDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TraitDeclaration
data AliasAs a = AliasAs { aliasAsName :: a, aliasAsModifier :: a, aliasAsClause :: a }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 AliasAs where liftEq = genericLiftEq
instance Ord1 AliasAs where liftCompare = genericLiftCompare
@ -391,7 +381,7 @@ instance Show1 AliasAs where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AliasAs
data InsteadOf a = InsteadOf a a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 InsteadOf where liftEq = genericLiftEq
instance Ord1 InsteadOf where liftCompare = genericLiftCompare
@ -399,7 +389,7 @@ instance Show1 InsteadOf where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InsteadOf
newtype TraitUseSpecification a = TraitUseSpecification [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TraitUseSpecification where liftEq = genericLiftEq
instance Ord1 TraitUseSpecification where liftCompare = genericLiftCompare
@ -407,7 +397,7 @@ instance Show1 TraitUseSpecification where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TraitUseSpecification
data TraitUseClause a = TraitUseClause [a] a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 TraitUseClause where liftEq = genericLiftEq
instance Ord1 TraitUseClause where liftCompare = genericLiftCompare
@ -415,7 +405,7 @@ instance Show1 TraitUseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TraitUseClause
data DestructorDeclaration a = DestructorDeclaration [a] a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 DestructorDeclaration where liftEq = genericLiftEq
instance Ord1 DestructorDeclaration where liftCompare = genericLiftCompare
@ -423,7 +413,7 @@ instance Show1 DestructorDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DestructorDeclaration
newtype Static a = Static ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Static where liftEq = genericLiftEq
instance Ord1 Static where liftCompare = genericLiftCompare
@ -431,7 +421,7 @@ instance Show1 Static where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Static
newtype ClassModifier a = ClassModifier ByteString
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ClassModifier where liftEq = genericLiftEq
instance Ord1 ClassModifier where liftCompare = genericLiftCompare
@ -439,7 +429,7 @@ instance Show1 ClassModifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassModifier
data ConstructorDeclaration a = ConstructorDeclaration [a] [a] a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 ConstructorDeclaration where liftEq = genericLiftEq
instance Ord1 ConstructorDeclaration where liftCompare = genericLiftCompare
@ -447,7 +437,7 @@ instance Show1 ConstructorDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ConstructorDeclaration
data PropertyDeclaration a = PropertyDeclaration a [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 PropertyDeclaration where liftEq = genericLiftEq
instance Ord1 PropertyDeclaration where liftCompare = genericLiftCompare
@ -455,7 +445,7 @@ instance Show1 PropertyDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PropertyDeclaration
data PropertyModifier a = PropertyModifier a a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 PropertyModifier where liftEq = genericLiftEq
instance Ord1 PropertyModifier where liftCompare = genericLiftCompare
@ -463,7 +453,7 @@ instance Show1 PropertyModifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PropertyModifier
data InterfaceDeclaration a = InterfaceDeclaration a a [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
@ -471,7 +461,7 @@ instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InterfaceDeclaration
newtype InterfaceBaseClause a = InterfaceBaseClause [a]
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 InterfaceBaseClause where liftEq = genericLiftEq
instance Ord1 InterfaceBaseClause where liftCompare = genericLiftCompare
@ -479,7 +469,7 @@ instance Show1 InterfaceBaseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InterfaceBaseClause
newtype Echo a = Echo a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Echo where liftEq = genericLiftEq
instance Ord1 Echo where liftCompare = genericLiftCompare
@ -487,7 +477,7 @@ instance Show1 Echo where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Echo
newtype Unset a = Unset a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Unset where liftEq = genericLiftEq
instance Ord1 Unset where liftCompare = genericLiftCompare
@ -495,7 +485,7 @@ instance Show1 Unset where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Unset
data Declare a = Declare a a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 Declare where liftEq = genericLiftEq
instance Ord1 Declare where liftCompare = genericLiftCompare
@ -503,7 +493,7 @@ instance Show1 Declare where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Declare
newtype DeclareDirective a = DeclareDirective a
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 DeclareDirective where liftEq = genericLiftEq
instance Ord1 DeclareDirective where liftCompare = genericLiftCompare
@ -511,7 +501,7 @@ instance Show1 DeclareDirective where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DeclareDirective
newtype LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a }
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
instance Eq1 LabeledStatement where liftEq = genericLiftEq
instance Ord1 LabeledStatement where liftCompare = genericLiftCompare

19
src/Language/Python/Assignment.hs
View File

@ -79,7 +79,6 @@ type Syntax =
, Syntax.Empty
, Syntax.Error
, Syntax.Identifier
, Syntax.Paren
, Syntax.Program
, Type.Annotation
, []
@ -191,7 +190,7 @@ keywordArgument :: Assignment
keywordArgument = makeTerm <$> symbol KeywordArgument <*> children (Statement.Assignment [] <$> term expression <*> term expression)
parenthesizedExpression :: Assignment
parenthesizedExpression = makeTerm <$> symbol ParenthesizedExpression <*> (Syntax.Paren <$> children expressions)
parenthesizedExpression = symbol ParenthesizedExpression *> children expressions
parameter :: Assignment
parameter = makeTerm <$> symbol DefaultParameter <*> children (Statement.Assignment [] <$> term expression <*> term expression)
@ -243,16 +242,11 @@ exceptClause = makeTerm <$> symbol ExceptClause <*> children
<*> expressions)
functionDefinition :: Assignment
functionDefinition
= makeFunctionDeclaration <$> symbol FunctionDefinition <*> children ((,,,) <$> term expression <* symbol Parameters <*> children (manyTerm expression) <*> optional (symbol Type *> children (term expression)) <*> expressions)
<|> makeAsyncFunctionDeclaration <$> symbol AsyncFunctionDefinition <*> children ((,,,,) <$> term async' <*> term expression <* symbol Parameters <*> children (manyTerm expression) <*> optional (symbol Type *> children (term expression)) <*> expressions)
functionDefinition =
makeFunctionDeclaration <$> symbol FunctionDefinition <*> children ((,,,) <$> term expression <* symbol Parameters <*> children (manyTerm expression) <*> optional (symbol Type *> children (term expression)) <*> expressions)
<|> makeFunctionDeclaration <$> (symbol Lambda' <|> symbol Lambda) <*> children ((,,,) <$ token AnonLambda <*> emptyTerm <*> (symbol LambdaParameters *> children (manyTerm expression) <|> pure []) <*> optional (symbol Type *> children (term expression)) <*> expressions)
where
makeFunctionDeclaration loc (functionName', functionParameters, ty, functionBody) = makeTerm loc $ Type.Annotation (makeTerm loc $ Declaration.Function [] functionName' functionParameters functionBody) (fromMaybe (makeTerm loc Syntax.Empty) ty)
makeAsyncFunctionDeclaration loc (async', functionName', functionParameters, ty, functionBody) = makeTerm loc $ Type.Annotation (makeTerm loc $ Type.Annotation (makeTerm loc $ Declaration.Function [] functionName' functionParameters functionBody) (fromMaybe (makeTerm loc Syntax.Empty) ty)) async'
async' :: Assignment
async' = makeTerm <$> symbol AnonAsync <*> (Syntax.Identifier . name <$> source)
classDefinition :: Assignment
classDefinition = makeTerm <$> symbol ClassDefinition <*> children (Declaration.Class [] <$> term expression <*> argumentList <*> expressions)
@ -300,8 +294,9 @@ binaryOperator = makeTerm' <$> symbol BinaryOperator <*> children (infixTerm exp
[ (inj .) . Expression.Plus <$ symbol AnonPlus
, (inj .) . Expression.Minus <$ symbol AnonMinus
, (inj .) . Expression.Times <$ symbol AnonStar
, (inj .) . Expression.Times <$ symbol AnonAt -- Matrix multiplication, TODO: May not want to assign to Expression.Times.
, (inj .) . Expression.DividedBy <$ symbol AnonSlash
, (inj .) . Expression.DividedBy <$ symbol AnonSlashSlash
, (inj .) . Expression.FloorDivision <$ symbol AnonSlashSlash
, (inj .) . Expression.Modulo <$ symbol AnonPercent
, (inj .) . Expression.Power <$ symbol AnonStarStar
, (inj .) . Expression.BOr <$ symbol AnonPipe
@ -318,11 +313,12 @@ booleanOperator = makeTerm' <$> symbol BooleanOperator <*> children (infixTerm e
])
assignment' :: Assignment
assignment' = makeTerm <$> symbol Assignment <*> children (Statement.Assignment [] <$> term expressionList <*> term rvalue)
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
@ -334,6 +330,7 @@ assignment' = makeTerm <$> symbol Assignment <*> children (Statement.Assignmen
, assign Expression.BXOr <$ symbol AnonCaretEqual
])
where rvalue = expressionList <|> assignment' <|> yield
makeAssignment loc (lhs, maybeType, rhs) = makeTerm loc (Statement.Assignment (maybeToList maybeType) lhs rhs)
assign :: (f :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Union Syntax Term
assign c l r = inj (Statement.Assignment [] l (makeTerm1 (c l r)))

48
src/Language/Python/Syntax.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-}
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables #-}
module Language.Python.Syntax where
import Data.Abstract.Environment as Env
@ -8,7 +8,7 @@ import Data.Abstract.Module
import Data.Align.Generic
import qualified Data.ByteString.Char8 as BC
import Data.Functor.Classes.Generic
import Data.List (intercalate)
import qualified Data.Language as Language
import qualified Data.List.NonEmpty as NonEmpty
import Data.Mergeable
import Diffing.Algorithm
@ -51,15 +51,15 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (BC.unpack prefix) (J
-- Subsequent imports of `parent.two` or `parent.three` will execute
-- `parent/two/__init__.py` and
-- `parent/three/__init__.py` respectively.
resolvePythonModules :: MonadEvaluatable location term value m => QualifiedName -> m (NonEmpty ModulePath)
resolvePythonModules :: forall value term location effects m. MonadEvaluatable location term value effects m => QualifiedName -> m effects (NonEmpty ModulePath)
resolvePythonModules q = do
relRootDir <- rootDir q <$> currentModule
for (moduleNames q) $ \name -> do
x <- trace ("resolving: " <> show name) $ search relRootDir name
trace ("found: " <> show x) (pure x)
x <- search relRootDir name
traceResolve name x $ pure x
where
rootDir (QualifiedName _) ModuleInfo{..} = takeDirectory (makeRelative moduleRoot modulePath)
rootDir (RelativeQualifiedName n _) ModuleInfo{..} = upDir numDots (takeDirectory (makeRelative moduleRoot modulePath))
rootDir (QualifiedName _) ModuleInfo{..} = mempty -- overall rootDir of the Package.
rootDir (RelativeQualifiedName n _) ModuleInfo{..} = upDir numDots (takeDirectory modulePath)
where numDots = pred (length n)
upDir n dir | n <= 0 = dir
| otherwise = takeDirectory (upDir (pred n) dir)
@ -68,25 +68,21 @@ resolvePythonModules q = do
moduleNames (RelativeQualifiedName x Nothing) = error $ "importing from '" <> show x <> "' is not implemented"
moduleNames (RelativeQualifiedName _ (Just paths)) = moduleNames paths
notFound xs = "Unable to resolve module import: " <> friendlyName q <> ", searched: " <> show xs
search rootDir x = do
traceM ("searching for " <> show x <> " in " <> show rootDir)
let path = normalise (rootDir </> normalise x)
let searchPaths = [ path </> "__init__.py"
, path <.> ".py"
]
trace ("searching in: " <> show searchPaths) $
resolve searchPaths >>= maybeFail (notFound searchPaths)
friendlyName :: QualifiedName -> String
friendlyName (QualifiedName xs) = intercalate "." (NonEmpty.toList xs)
friendlyName (RelativeQualifiedName prefix qn) = prefix <> maybe "" friendlyName qn
modulePath <- resolve searchPaths
maybe (throwResumable @(ResolutionError value) $ NotFoundError path searchPaths Language.Python) pure modulePath
-- | 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 :: ![(Name, Name)] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Import where liftEq = genericLiftEq
instance Ord1 Import where liftCompare = genericLiftCompare
@ -105,7 +101,7 @@ instance Evaluatable Import where
-- Last module path is the one we want to import
let path = NonEmpty.last modulePaths
(importedEnv, _) <- isolate (require path)
modifyEnv (mappend (select importedEnv))
modifyEnv (mergeEnvs (select importedEnv))
unit
where
select importedEnv
@ -114,7 +110,7 @@ instance Evaluatable Import where
newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: QualifiedName }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 QualifiedImport where liftEq = genericLiftEq
instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
@ -122,7 +118,7 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec
-- import a.b.c
instance Evaluatable QualifiedImport where
eval (QualifiedImport (RelativeQualifiedName _ _)) = fail "technically this is not allowed in python"
eval (QualifiedImport (RelativeQualifiedName _ _)) = raise (fail "technically this is not allowed in python")
eval (QualifiedImport name@(QualifiedName qualifiedName)) = do
modulePaths <- resolvePythonModules name
go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths)
@ -130,17 +126,17 @@ instance Evaluatable QualifiedImport where
-- Evaluate and import the last module, updating the environment
go ((name, path) :| []) = letrec' name $ \addr -> do
(importedEnv, _) <- isolate (require path)
modifyEnv (mappend importedEnv)
void $ makeNamespace name addr []
modifyEnv (mergeEnvs importedEnv)
void $ makeNamespace name addr Nothing
unit
-- Evaluate each parent module, creating a just namespace
go ((name, path) :| xs) = letrec' name $ \addr -> do
void $ isolate (require path)
void $ go (NonEmpty.fromList xs)
makeNamespace name addr []
makeNamespace name addr Nothing
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportFrom :: QualifiedName, qualifiedAliasedImportAlias :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq
instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare
@ -159,13 +155,13 @@ instance Evaluatable QualifiedAliasedImport where
letrec' alias $ \addr -> do
let path = NonEmpty.last modulePaths
(importedEnv, _) <- isolate (require path)
modifyEnv (mappend importedEnv)
void $ makeNamespace alias addr []
modifyEnv (mergeEnvs importedEnv)
void $ makeNamespace alias addr Nothing
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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Ellipsis where liftEq = genericLiftEq
instance Ord1 Ellipsis where liftCompare = genericLiftCompare
@ -176,7 +172,7 @@ instance Evaluatable Ellipsis
data Redirect a = Redirect !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Redirect where liftEq = genericLiftEq
instance Ord1 Redirect where liftCompare = genericLiftCompare

111
src/Language/Ruby/Assignment.hs
View File

@ -17,6 +17,7 @@ import qualified Assigning.Assignment as Assignment
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
@ -28,6 +29,7 @@ type Syntax = '[
Comment.Comment
, Declaration.Function
, Declaration.Method
, Directive.File
, Expression.Arithmetic
, Expression.Bitwise
, Expression.Boolean
@ -72,14 +74,13 @@ type Syntax = '[
, Syntax.Empty
, Syntax.Error
, Syntax.Identifier
, Syntax.Paren
, Syntax.Program
, Ruby.Syntax.Send
, Ruby.Syntax.Class
, Ruby.Syntax.Load
, Ruby.Syntax.LowPrecedenceBoolean
, Ruby.Syntax.Module
, Ruby.Syntax.Require
, Ruby.Syntax.Send
, []
]
@ -144,12 +145,24 @@ expressions :: Assignment
expressions = makeTerm'' <$> location <*> many expression
parenthesizedExpressions :: Assignment
parenthesizedExpressions = makeTerm'' <$> symbol ParenthesizedStatements <*> children (Syntax.Paren <$> expressions)
parenthesizedExpressions = makeTerm'' <$> symbol ParenthesizedStatements <*> children (many expression)
withExtendedScope :: Assignment' a -> Assignment' a
withExtendedScope inner = do
locals <- getRubyLocals
result <- inner
putRubyLocals locals
pure result
withNewScope :: Assignment' a -> Assignment' a
withNewScope inner = withExtendedScope $ do
putRubyLocals []
inner
-- Looks up identifiers in the list of locals to determine vcall vs. local identifier.
identifier :: Assignment
identifier =
mk Identifier
<|> mk Identifier'
vcallOrLocal
<|> mk Constant
<|> mk InstanceVariable
<|> mk ClassVariable
@ -162,7 +175,17 @@ identifier =
<|> mk HashSplatArgument
<|> mk BlockArgument
<|> mk Uninterpreted
where mk s = makeTerm <$> symbol s <*> (Syntax.Identifier . name <$> source)
where
mk s = makeTerm <$> symbol s <*> (Syntax.Identifier . name <$> source)
vcallOrLocal = do
(loc, ident, locals) <- identWithLocals
case ident of
"__FILE__" -> pure $ makeTerm loc Directive.File
_ -> 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)
-- TODO: Handle interpolation in all literals that support it (strings, regexes, symbols, subshells, etc).
literal :: Assignment
@ -182,7 +205,7 @@ literal =
<|> makeTerm <$> symbol String <*> (Literal.TextElement <$> source)
<|> makeTerm <$> symbol ChainedString <*> children (many (makeTerm <$> symbol String <*> (Literal.TextElement <$> source)))
<|> makeTerm <$> symbol Regex <*> (Literal.Regex <$> source)
<|> makeTerm <$> symbol Symbol <*> (Literal.Symbol <$> source)
<|> makeTerm <$> (symbol Symbol <|> symbol Symbol') <*> (Literal.Symbol <$> source)
heredoc :: Assignment
heredoc = makeTerm <$> symbol HeredocBeginning <*> (Literal.TextElement <$> source)
@ -195,48 +218,65 @@ endBlock :: Assignment
endBlock = makeTerm <$> symbol EndBlock <*> children (Statement.ScopeExit <$> many expression)
class' :: Assignment
class' = makeTerm <$> symbol Class <*> children (Ruby.Syntax.Class <$> expression <*> (superclass <|> pure []) <*> expressions)
where superclass = pure <$ symbol Superclass <*> children expression
class' = makeTerm <$> symbol Class <*> (withNewScope . children) (Ruby.Syntax.Class <$> expression <*> optional superclass <*> expressions)
where
superclass :: Assignment
superclass = symbol Superclass *> children expression
singletonClass :: Assignment
singletonClass = makeTerm <$> symbol SingletonClass <*> children (Ruby.Syntax.Class <$> expression <*> pure [] <*> expressions)
singletonClass = makeTerm <$> symbol SingletonClass <*> (withNewScope . children) (Ruby.Syntax.Class <$> expression <*> pure Nothing <*> expressions)
module' :: Assignment
module' = makeTerm <$> symbol Module <*> children (Ruby.Syntax.Module <$> expression <*> many expression)
module' = makeTerm <$> symbol Module <*> (withNewScope . children) (Ruby.Syntax.Module <$> expression <*> many expression)
scopeResolution :: Assignment
scopeResolution = makeTerm <$> symbol ScopeResolution <*> children (Expression.ScopeResolution <$> many expression)
parameter :: Assignment
parameter =
mk SplatParameter
<|> mk HashSplatParameter
<|> mk BlockParameter
<|> mk KeywordParameter
<|> mk OptionalParameter
<|> makeTerm <$> symbol DestructuredParameter <*> children (many parameter)
<|> expression
where mk s = makeTerm <$> symbol s <*> (Syntax.Identifier . name <$> source)
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)
method :: Assignment
method = makeTerm <$> symbol Method <*> children (Declaration.Method [] <$> emptyTerm <*> expression <*> params <*> expressions')
method = makeTerm <$> symbol Method <*> (withNewScope . children) (Declaration.Method <$> pure [] <*> emptyTerm <*> methodSelector <*> params <*> expressions')
where params = symbol MethodParameters *> children (many parameter) <|> pure []
expressions' = makeTerm <$> location <*> many expression
singletonMethod :: Assignment
singletonMethod = makeTerm <$> symbol SingletonMethod <*> children (Declaration.Method <$> pure [] <*> expression <*> expression <*> params <*> expressions)
singletonMethod = makeTerm <$> symbol SingletonMethod <*> (withNewScope . children) (Declaration.Method <$> pure [] <*> expression <*> methodSelector <*> params <*> expressions)
where params = symbol MethodParameters *> children (many parameter) <|> pure []
lambda :: Assignment
lambda = makeTerm <$> symbol Lambda <*> children (
lambda = makeTerm <$> symbol Lambda <*> (withExtendedScope . children) (
Declaration.Function [] <$> emptyTerm
<*> ((symbol BlockParameters <|> symbol LambdaParameters) *> children (many parameter) <|> pure [])
<*> expressions)
block :: Assignment
block = makeTerm <$> symbol DoBlock <*> children (Declaration.Function <$> pure [] <*> emptyTerm <*> params <*> expressions)
<|> makeTerm <$> symbol Block <*> children (Declaration.Function <$> pure [] <*> emptyTerm <*> params <*> expressions)
where params = symbol BlockParameters *> children (many parameter) <|> pure []
block = makeTerm <$> symbol DoBlock <*> scopedBlockChildren
<|> makeTerm <$> symbol Block <*> scopedBlockChildren
where scopedBlockChildren = withExtendedScope blockChildren
blockChildren = children (Declaration.Function <$> pure [] <*> emptyTerm <*> params <*> expressions)
params = symbol BlockParameters *> children (many parameter) <|> pure []
comment :: Assignment
comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source)
@ -306,7 +346,7 @@ methodCall = makeTerm' <$> symbol MethodCall <*> children (require <|> load <|>
dotCall = symbol Call *> children (Ruby.Syntax.Send <$> (Just <$> term expression) <*> pure Nothing <*> args)
selector = Just <$> term methodSelector
require = inj <$> ((symbol Identifier <|> symbol Identifier') *> do
require = inj <$> (symbol Identifier *> do
s <- source
guard (s `elem` ["require", "require_relative"])
Ruby.Syntax.Require (s == "require_relative") <$> nameExpression)
@ -321,9 +361,9 @@ methodSelector :: Assignment
methodSelector = makeTerm <$> symbols <*> (Syntax.Identifier <$> (name <$> source))
where
symbols = symbol Identifier
<|> 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
@ -370,8 +410,23 @@ assignment' = makeTerm <$> symbol Assignment <*> children (Statement.As
rhs = makeTerm <$> symbol RightAssignmentList <*> children (many expr) <|> expr
expr = makeTerm <$> symbol RestAssignment <*> (Syntax.Identifier . name <$> source)
<|> makeTerm <$> symbol DestructuredLeftAssignment <*> children (many expr)
<|> lhsIdent
<|> expression
identWithLocals :: Assignment' (Record Location, ByteString, [ByteString])
identWithLocals = do
loc <- symbol Identifier
-- source advances, so it's important we call getRubyLocals first
locals <- getRubyLocals
ident <- source
pure (loc, ident, locals)
lhsIdent :: Assignment
lhsIdent = do
(loc, ident, locals) <- identWithLocals
putRubyLocals (ident : locals)
pure $ makeTerm loc (Syntax.Identifier (name ident))
unary :: Assignment
unary = symbol Unary >>= \ location ->
makeTerm location . Expression.Complement <$> children ( symbol AnonTilde *> expression )

58
src/Language/Ruby/Syntax.hs
View File

@ -7,6 +7,7 @@ import Data.Abstract.Module (ModulePath)
import Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Path
import qualified Data.ByteString.Char8 as BC
import qualified Data.Language as Language
import Diffing.Algorithm
import Prelude hiding (fail)
import Prologue
@ -16,28 +17,25 @@ import System.FilePath.Posix
-- TODO: Fully sort out ruby require/load mechanics
--
-- require "json"
resolveRubyName :: forall value term location m. MonadEvaluatable location term value m => ByteString -> m ModulePath
resolveRubyName :: forall value term location effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
resolveRubyName name = do
let name' = cleanNameOrPath name
modulePath <- resolve [name' <.> "rb"]
maybe (throwException @(ResolutionError value) $ RubyError name') pure modulePath
let paths = [name' <.> "rb"]
modulePath <- resolve paths
maybe (throwResumable @(ResolutionError value) $ NotFoundError name' paths Language.Ruby) pure modulePath
-- load "/root/src/file.rb"
resolveRubyPath :: forall value term location m. MonadEvaluatable location term value m => ByteString -> m ModulePath
resolveRubyPath :: forall value term location effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
resolveRubyPath path = do
let name' = cleanNameOrPath path
modulePath <- resolve [name']
maybe (throwException @(ResolutionError value) $ RubyError name') pure modulePath
maybeFailNotFound :: MonadFail m => String -> Maybe a -> m a
maybeFailNotFound name = maybeFail notFound
where notFound = "Unable to resolve: " <> name
maybe (throwResumable @(ResolutionError value) $ NotFoundError name' [name'] Language.Ruby) pure modulePath
cleanNameOrPath :: ByteString -> String
cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes
data Send a = Send { sendReceiver :: Maybe a, sendSelector :: Maybe a, sendArgs :: [a], sendBlock :: Maybe a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Send where liftEq = genericLiftEq
instance Ord1 Send where liftCompare = genericLiftCompare
@ -48,17 +46,11 @@ instance Evaluatable Send where
let sel = case sendSelector of
Just sel -> subtermValue sel
Nothing -> variable (name "call")
func <- case sendReceiver of
Just recv -> do
recvEnv <- subtermValue recv >>= scopedEnvironment
localEnv (mappend recvEnv) sel
Nothing -> sel -- TODO Does this require `localize` so we don't leak terms when resolving `sendSelector`?
func <- maybe sel (flip evaluateInScopedEnv sel . subtermValue) sendReceiver
call func (map subtermValue sendArgs) -- TODO pass through sendBlock
data Require a = Require { requireRelative :: Bool, requirePath :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Require where liftEq = genericLiftEq
instance Ord1 Require where liftCompare = genericLiftCompare
@ -68,13 +60,13 @@ instance Evaluatable Require where
eval (Require _ x) = do
name <- subtermValue x >>= asString
path <- resolveRubyName name
(importedEnv, v) <- isolate (doRequire path)
(importedEnv, v) <- traceResolve name path $ isolate (doRequire path)
modifyEnv (`mergeNewer` importedEnv)
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 :: MonadEvaluatable location term value m
doRequire :: MonadEvaluatable location term value effects m
=> ModulePath
-> m (Environment location value, value)
-> m effects (Environment location value, value)
doRequire name = do
moduleTable <- getModuleTable
case ModuleTable.lookup name moduleTable of
@ -83,7 +75,7 @@ doRequire name = do
newtype Load a = Load { loadArgs :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Load where liftEq = genericLiftEq
instance Ord1 Load where liftCompare = genericLiftCompare
@ -97,19 +89,19 @@ instance Evaluatable Load where
path <- subtermValue x >>= asString
shouldWrap <- subtermValue wrap >>= asBool
doLoad path shouldWrap
eval (Load _) = fail "invalid argument supplied to load, path is required"
eval (Load _) = raise (fail "invalid argument supplied to load, path is required")
doLoad :: MonadEvaluatable location term value m => ByteString -> Bool -> m value
doLoad :: MonadEvaluatable location term value effects m => ByteString -> Bool -> m effects value
doLoad path shouldWrap = do
path' <- resolveRubyPath path
(importedEnv, _) <- isolate (load path')
unless shouldWrap $ modifyEnv (mappend importedEnv)
(importedEnv, _) <- traceResolve path path' $ isolate (load path')
unless shouldWrap $ modifyEnv (mergeEnvs importedEnv)
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, classSuperClasses :: ![a], classBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
data Class a = Class { classIdentifier :: !a, classSuperClass :: !(Maybe a), classBody :: !a }
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Diffable Class where
equivalentBySubterm = Just . classIdentifier
@ -120,13 +112,13 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Class where
eval Class{..} = do
supers <- traverse subtermValue classSuperClasses
super <- traverse subtermValue classSuperClass
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
letrec' name $ \addr ->
subtermValue classBody <* makeNamespace name addr supers
subtermValue classBody <* makeNamespace name addr super
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Module where liftEq = genericLiftEq
instance Ord1 Module where liftCompare = genericLiftCompare
@ -136,12 +128,12 @@ instance Evaluatable Module where
eval (Module iden xs) = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
letrec' name $ \addr ->
eval xs <* makeNamespace name addr []
eval xs <* makeNamespace name addr Nothing
data LowPrecedenceBoolean a
= LowAnd !a !a
| LowOr !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Evaluatable LowPrecedenceBoolean where
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands

42
src/Language/TypeScript/Assignment.hs
View File

@ -66,10 +66,12 @@ type Syntax = '[
, Statement.Break
, Statement.Catch
, Statement.Continue
, Statement.DoWhile
, Statement.Else
, Statement.Finally
, Statement.For
, Statement.ForEach
, Statement.HashBang
, Statement.If
, Statement.Match
, Statement.Pattern
@ -77,16 +79,14 @@ type Syntax = '[
, Statement.Return
, Statement.ScopeEntry
, Statement.ScopeExit
, Statement.Throw
, Statement.Try
, Statement.While
, Statement.Yield
, Statement.Throw
, Statement.DoWhile
, Syntax.AccessibilityModifier
, Syntax.Empty
, Syntax.Error
, Syntax.Identifier
, Syntax.Paren
, Syntax.Program
, Syntax.Context
, Type.Readonly
@ -165,6 +165,7 @@ type Syntax = '[
, TypeScript.Syntax.DefaultExport
, TypeScript.Syntax.QualifiedExport
, TypeScript.Syntax.QualifiedExportFrom
, TypeScript.Syntax.JavaScriptRequire
, []
]
@ -232,8 +233,8 @@ assignmentExpression :: Assignment
assignmentExpression = makeTerm <$> symbol AssignmentExpression <*> children (Statement.Assignment [] <$> term (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) <*> expression)
augmentedAssignmentExpression :: Assignment
augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpression <*> children (infixTerm (memberExpression <|> subscriptExpression <|> identifier <|> destructuringPattern) expression [
assign Expression.Plus <$ symbol AnonPlusEqual
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
@ -241,7 +242,9 @@ augmentedAssignmentExpression = makeTerm' <$> symbol AugmentedAssignmentExpressi
, 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 :< Syntax) => (Term -> Term -> f Term) -> Term -> Term -> Union Syntax Term
assign c l r = inj (Statement.Assignment [] l (makeTerm1 (c l r)))
@ -481,8 +484,9 @@ function :: Assignment
function = makeFunction <$> (symbol Grammar.Function <|> symbol Grammar.GeneratorFunction) <*> 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
ambientFunction = makeAmbientFunction <$> symbol Grammar.AmbientFunction <*> children ((,) <$> term identifier <*> callSignatureParts)
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
@ -598,6 +602,7 @@ statement = handleError everything
, continueStatement
, returnStatement
, throwStatement
, hashBang
, emptyStatement
, labeledStatement ]
@ -611,20 +616,23 @@ doStatement :: Assignment
doStatement = makeTerm <$> symbol DoStatement <*> children (flip Statement.DoWhile <$> term statement <*> term parenthesizedExpression)
continueStatement :: Assignment
continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (statementIdentifier <|> emptyTerm))
continueStatement = makeTerm <$> symbol ContinueStatement <*> children (Statement.Continue <$> (statementIdentifier <|> term emptyTerm))
breakStatement :: Assignment
breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (statementIdentifier <|> emptyTerm))
breakStatement = makeTerm <$> symbol BreakStatement <*> children (Statement.Break <$> (statementIdentifier <|> term emptyTerm))
withStatement :: Assignment
withStatement = makeTerm <$> symbol WithStatement <*> children (TypeScript.Syntax.With <$> term parenthesizedExpression <*> term statement)
returnStatement :: Assignment
returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expressions <|> emptyTerm))
returnStatement = makeTerm <$> symbol ReturnStatement <*> children (Statement.Return <$> (term expressions <|> term emptyTerm))
throwStatement :: Assignment
throwStatement = makeTerm <$> symbol Grammar.ThrowStatement <*> children (Statement.Throw <$> term expressions)
hashBang :: Assignment
hashBang = makeTerm <$> symbol HashBangLine <*> (Statement.HashBang <$> source)
labeledStatement :: Assignment
labeledStatement = makeTerm <$> symbol Grammar.LabeledStatement <*> children (TypeScript.Syntax.LabeledStatement <$> statementIdentifier <*> term statement)
@ -780,11 +788,21 @@ variableDeclaration :: Assignment
variableDeclaration = makeTerm <$> (symbol Grammar.VariableDeclaration <|> symbol Grammar.LexicalDeclaration) <*> children (Declaration.VariableDeclaration <$> manyTerm variableDeclarator)
variableDeclarator :: Assignment
variableDeclarator = 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)
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 <|> symbol Identifier') *> do
s <- source
guard (s == "require")
symbol Arguments *> children (symbol Grammar.String *> (TypeScript.Syntax.importPath <$> source))
)
parenthesizedExpression :: Assignment
parenthesizedExpression = makeTerm <$> symbol ParenthesizedExpression <*> (Syntax.Paren <$> children (term expressions))
parenthesizedExpression = symbol ParenthesizedExpression *> children (term expressions)
switchStatement :: Assignment
switchStatement = makeTerm <$> symbol SwitchStatement <*> children (Statement.Match <$> term parenthesizedExpression <*> term switchBody)

279
src/Language/TypeScript/Syntax.hs
View File

@ -1,14 +1,16 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveAnyClass, ScopedTypeVariables #-}
module Language.TypeScript.Syntax where
import qualified Data.Abstract.Environment as Env
import qualified Data.Abstract.FreeVariables as FV
import Data.Abstract.Evaluatable
import Data.Abstract.Path
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString as B
import Data.Abstract.Module (ModulePath, ModuleInfo(..))
import qualified Data.Language as Language
import Diffing.Algorithm
import Prelude hiding (fail)
import Prelude
import Prologue
import System.FilePath.Posix
@ -28,9 +30,11 @@ importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (path
toName :: ImportPath -> Name
toName = FV.name . BC.pack . unPath
resolveTypeScriptModule :: MonadEvaluatable location term value m => ImportPath -> m ModulePath
resolveTypeScriptModule (ImportPath path Relative) = resolveRelativeTSModule path
resolveTypeScriptModule (ImportPath path NonRelative) = resolveNonRelativeTSModule path
-- Node.js resolution algorithm: https://nodejs.org/api/modules.html#modules_all_together
-- TypeScript has a couple of different strategies, but the main one mimics Node.js.
resolveWithNodejsStrategy :: MonadEvaluatable location term value effects m => ImportPath -> [String] -> m effects ModulePath
resolveWithNodejsStrategy (ImportPath path Relative) exts = resolveRelativePath path exts
resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts
-- | Resolve a relative TypeScript import to a known 'ModuleName' or fail.
--
@ -39,14 +43,14 @@ resolveTypeScriptModule (ImportPath path NonRelative) = resolveNonRelativeTSModu
-- /root/src/moduleB.ts
-- /root/src/moduleB/package.json (if it specifies a "types" property)
-- /root/src/moduleB/index.ts
resolveRelativeTSModule :: MonadEvaluatable location term value m => FilePath -> m ModulePath
resolveRelativeTSModule relImportPath = do
resolveRelativePath :: forall value term location effects m. MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects ModulePath
resolveRelativePath relImportPath exts = do
ModuleInfo{..} <- currentModule
let relRootDir = takeDirectory (makeRelative moduleRoot modulePath)
let path = normalise (relRootDir </> normalise relImportPath)
resolveTSModule path >>= either notFound pure
let relRootDir = takeDirectory modulePath
let path = joinPaths relRootDir relImportPath
resolveTSModule path exts >>= either notFound (\x -> traceResolve relImportPath x (pure x))
where
notFound xs = fail $ "Unable to resolve relative module import: " <> show relImportPath <> ", looked for it in: " <> show xs
notFound xs = throwResumable @(ResolutionError value) $ NotFoundError relImportPath xs Language.TypeScript
-- | Resolve a non-relative TypeScript import to a known 'ModuleName' or fail.
--
@ -58,34 +62,45 @@ resolveRelativeTSModule relImportPath = do
--
-- /root/node_modules/moduleB.ts, etc
-- /node_modules/moduleB.ts, etc
resolveNonRelativeTSModule :: MonadEvaluatable location term value m => FilePath -> m ModulePath
resolveNonRelativeTSModule name = do
resolveNonRelativePath :: forall value term location effects m. MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects ModulePath
resolveNonRelativePath name exts = do
ModuleInfo{..} <- currentModule
go "." (makeRelative moduleRoot modulePath) mempty
go "." modulePath mempty
where
nodeModulesPath dir = takeDirectory dir </> "node_modules" </> name
-- Recursively search in a 'node_modules' directory, stepping up a directory each time.
go root path searched = do
res <- resolveTSModule (nodeModulesPath path)
res <- resolveTSModule (nodeModulesPath path) exts
case res of
Left xs | parentDir <- takeDirectory path , root /= parentDir -> go root parentDir (searched <> xs)
| otherwise -> notFound (searched <> xs)
Right m -> pure m
notFound xs = fail $ "Unable to resolve non-relative module import: " <> show name <> ", looked for it in: " <> show xs
Right m -> traceResolve name m $ pure m
notFound xs = throwResumable @(ResolutionError value) $ NotFoundError name xs Language.TypeScript
resolveTSModule :: MonadEvaluatable location term value m => FilePath -> m (Either [FilePath] ModulePath)
resolveTSModule path = maybe (Left searchPaths) Right <$> resolve searchPaths
where exts = ["ts", "tsx", "d.ts"]
searchPaths =
resolveTSModule :: MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects (Either [FilePath] ModulePath)
resolveTSModule path exts = maybe (Left searchPaths) Right <$> resolve searchPaths
where searchPaths =
((path <.>) <$> exts)
-- TODO: Requires parsing package.json, getting the path of the
-- "types" property and adding that value to the search Paths.
-- <> [searchDir </> "package.json"]
<> (((path </> "index") <.>) <$> exts)
typescriptExtensions :: [String]
typescriptExtensions = ["ts", "tsx", "d.ts"]
javascriptExtensions :: [String]
javascriptExtensions = ["js"]
evalRequire :: MonadEvaluatable location term value effects m => ModulePath -> Name -> m effects value
evalRequire modulePath alias = letrec' alias $ \addr -> do
(importedEnv, _) <- isolate (require modulePath)
modifyEnv (mergeEnvs importedEnv)
void $ makeNamespace alias addr Nothing
unit
data Import a = Import { importSymbols :: ![(Name, Name)], importFrom :: ImportPath }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Import where liftEq = genericLiftEq
instance Ord1 Import where liftCompare = genericLiftCompare
@ -94,33 +109,43 @@ 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 <- resolveTypeScriptModule importPath
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
(importedEnv, _) <- isolate (require modulePath)
modifyEnv (mappend (renamed importedEnv)) *> unit
modifyEnv (mergeEnvs (renamed importedEnv)) *> unit
where
renamed importedEnv
| Prologue.null symbols = importedEnv
| otherwise = Env.overwrite symbols importedEnv
data JavaScriptRequire a = JavaScriptRequire { javascriptRequireIden :: !a, javascriptRequireFrom :: ImportPath }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
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
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
evalRequire modulePath alias
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
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 <- resolveTypeScriptModule importPath
eval (QualifiedAliasedImport aliasTerm importPath) = do
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
letrec' alias $ \addr -> do
(importedEnv, _) <- isolate (require modulePath)
modifyEnv (mappend importedEnv)
void $ makeNamespace alias addr []
unit
evalRequire modulePath alias
newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 SideEffectImport where liftEq = genericLiftEq
instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
@ -128,14 +153,14 @@ instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable SideEffectImport where
eval (SideEffectImport importPath) = do
modulePath <- resolveTypeScriptModule importPath
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
void $ isolate (require modulePath)
unit
-- | Qualified Export declarations
newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [(Name, Name)] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 QualifiedExport where liftEq = genericLiftEq
instance Ord1 QualifiedExport where liftCompare = genericLiftCompare
@ -151,7 +176,7 @@ instance Evaluatable QualifiedExport where
-- | Qualified Export declarations that export from another module.
data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: ImportPath, qualifiedExportFromSymbols :: ![(Name, Name)]}
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq
instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare
@ -159,31 +184,37 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable QualifiedExportFrom where
eval (QualifiedExportFrom importPath exportSymbols) = do
modulePath <- resolveTypeScriptModule importPath
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
(importedEnv, _) <- isolate (require modulePath)
-- Look up addresses in importedEnv and insert the aliases with addresses into the exports.
for_ exportSymbols $ \(name, alias) -> do
let address = Env.lookup name importedEnv
maybe (cannotExport modulePath name) (addExport name alias . Just) address
maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address
unit
where
cannotExport moduleName name = fail $
"module " <> show moduleName <> " does not export " <> show (unName name)
newtype DefaultExport a = DefaultExport { defaultExport :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 DefaultExport where liftEq = genericLiftEq
instance Ord1 DefaultExport where liftCompare = genericLiftCompare
instance Show1 DefaultExport where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DefaultExport where
eval (DefaultExport term) = do
v <- subtermValue term
case declaredName term of
Just name -> do
addr <- lookupOrAlloc name
assign addr v
addExport name name Nothing
void $ modifyEnv (Env.insert name addr)
Nothing -> throwEvalError DefaultExportError
unit
-- | Lookup type for a type-level key in a typescript map.
data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 LookupType where liftEq = genericLiftEq
instance Ord1 LookupType where liftCompare = genericLiftCompare
@ -192,7 +223,7 @@ instance Evaluatable LookupType
-- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo }
newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ShorthandPropertyIdentifier where liftEq = genericLiftEq
instance Ord1 ShorthandPropertyIdentifier where liftCompare = genericLiftCompare
@ -200,7 +231,7 @@ instance Show1 ShorthandPropertyIdentifier where liftShowsPrec = genericLiftShow
instance Evaluatable ShorthandPropertyIdentifier
data Union a = Union { _unionLeft :: !a, _unionRight :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Language.TypeScript.Syntax.Union where liftEq = genericLiftEq
instance Ord1 Language.TypeScript.Syntax.Union where liftCompare = genericLiftCompare
@ -208,7 +239,7 @@ instance Show1 Language.TypeScript.Syntax.Union where liftShowsPrec = genericLif
instance Evaluatable Language.TypeScript.Syntax.Union
data Intersection a = Intersection { _intersectionLeft :: !a, _intersectionRight :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Intersection where liftEq = genericLiftEq
instance Ord1 Intersection where liftCompare = genericLiftCompare
@ -216,7 +247,7 @@ instance Show1 Intersection where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Intersection
data FunctionType a = FunctionType { _functionTypeParameters :: !a, _functionFormalParameters :: ![a], _functionType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 FunctionType where liftEq = genericLiftEq
instance Ord1 FunctionType where liftCompare = genericLiftCompare
@ -224,7 +255,7 @@ instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable FunctionType
data AmbientFunction a = AmbientFunction { _ambientFunctionContext :: ![a], _ambientFunctionIdentifier :: !a, _ambientFunctionParameters :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 AmbientFunction where liftEq = genericLiftEq
instance Ord1 AmbientFunction where liftCompare = genericLiftCompare
@ -232,7 +263,7 @@ instance Show1 AmbientFunction where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AmbientFunction
data ImportRequireClause a = ImportRequireClause { _importRequireIdentifier :: !a, _importRequireSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ImportRequireClause where liftEq = genericLiftEq
instance Ord1 ImportRequireClause where liftCompare = genericLiftCompare
@ -240,7 +271,7 @@ instance Show1 ImportRequireClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImportRequireClause
newtype ImportClause a = ImportClause { _importClauseElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ImportClause where liftEq = genericLiftEq
instance Ord1 ImportClause where liftCompare = genericLiftCompare
@ -248,7 +279,7 @@ instance Show1 ImportClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImportClause
newtype Tuple a = Tuple { _tupleElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Tuple where liftEq = genericLiftEq
instance Ord1 Tuple where liftCompare = genericLiftCompare
@ -258,7 +289,7 @@ instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Tuple
data Constructor a = Constructor { _constructorTypeParameters :: !a, _constructorFormalParameters :: ![a], _constructorType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Language.TypeScript.Syntax.Constructor where liftEq = genericLiftEq
instance Ord1 Language.TypeScript.Syntax.Constructor where liftCompare = genericLiftCompare
@ -266,7 +297,7 @@ instance Show1 Language.TypeScript.Syntax.Constructor where liftShowsPrec = gene
instance Evaluatable Language.TypeScript.Syntax.Constructor
data TypeParameter a = TypeParameter { _typeParameter :: !a, _typeParameterConstraint :: !a, _typeParameterDefaultType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeParameter where liftEq = genericLiftEq
instance Ord1 TypeParameter where liftCompare = genericLiftCompare
@ -274,7 +305,7 @@ instance Show1 TypeParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeParameter
data TypeAssertion a = TypeAssertion { _typeAssertionParameters :: !a, _typeAssertionExpression :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeAssertion where liftEq = genericLiftEq
instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
@ -282,7 +313,7 @@ instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeAssertion
newtype Annotation a = Annotation { _annotationType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Annotation where liftEq = genericLiftEq
instance Ord1 Annotation where liftCompare = genericLiftCompare
@ -290,7 +321,7 @@ instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Annotation
newtype Decorator a = Decorator { _decoratorTerm :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Decorator where liftEq = genericLiftEq
instance Ord1 Decorator where liftCompare = genericLiftCompare
@ -298,7 +329,7 @@ instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Decorator
newtype ComputedPropertyName a = ComputedPropertyName a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ComputedPropertyName where liftEq = genericLiftEq
instance Ord1 ComputedPropertyName where liftCompare = genericLiftCompare
@ -306,7 +337,7 @@ instance Show1 ComputedPropertyName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ComputedPropertyName
newtype Constraint a = Constraint { _constraintType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Constraint where liftEq = genericLiftEq
instance Ord1 Constraint where liftCompare = genericLiftCompare
@ -314,7 +345,7 @@ instance Show1 Constraint where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Constraint
newtype DefaultType a = DefaultType { _defaultType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 DefaultType where liftEq = genericLiftEq
instance Ord1 DefaultType where liftCompare = genericLiftCompare
@ -322,7 +353,7 @@ instance Show1 DefaultType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DefaultType
newtype ParenthesizedType a = ParenthesizedType { _parenthesizedType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ParenthesizedType where liftEq = genericLiftEq
instance Ord1 ParenthesizedType where liftCompare = genericLiftCompare
@ -330,7 +361,7 @@ instance Show1 ParenthesizedType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ParenthesizedType
newtype PredefinedType a = PredefinedType { _predefinedType :: ByteString }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 PredefinedType where liftEq = genericLiftEq
instance Ord1 PredefinedType where liftCompare = genericLiftCompare
@ -338,7 +369,7 @@ instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PredefinedType
newtype TypeIdentifier a = TypeIdentifier ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeIdentifier where liftEq = genericLiftEq
instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare
@ -346,7 +377,7 @@ instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeIdentifier
data NestedIdentifier a = NestedIdentifier !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 NestedIdentifier where liftEq = genericLiftEq
instance Ord1 NestedIdentifier where liftCompare = genericLiftCompare
@ -354,7 +385,7 @@ instance Show1 NestedIdentifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NestedIdentifier
data NestedTypeIdentifier a = NestedTypeIdentifier !a !a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 NestedTypeIdentifier where liftEq = genericLiftEq
instance Ord1 NestedTypeIdentifier where liftCompare = genericLiftCompare
@ -362,7 +393,7 @@ instance Show1 NestedTypeIdentifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NestedTypeIdentifier
data GenericType a = GenericType { _genericTypeIdentifier :: !a, _genericTypeArguments :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 GenericType where liftEq = genericLiftEq
instance Ord1 GenericType where liftCompare = genericLiftCompare
@ -370,7 +401,7 @@ instance Show1 GenericType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable GenericType
data TypePredicate a = TypePredicate { _typePredicateIdentifier :: !a, _typePredicateType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypePredicate where liftEq = genericLiftEq
instance Ord1 TypePredicate where liftCompare = genericLiftCompare
@ -378,7 +409,7 @@ instance Show1 TypePredicate where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypePredicate
newtype ObjectType a = ObjectType { _objectTypeElements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ObjectType where liftEq = genericLiftEq
instance Ord1 ObjectType where liftCompare = genericLiftCompare
@ -386,7 +417,7 @@ instance Show1 ObjectType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ObjectType
data With a = With { _withExpression :: !a, _withBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 With where liftEq = genericLiftEq
instance Ord1 With where liftCompare = genericLiftCompare
@ -394,7 +425,7 @@ instance Show1 With where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable With
newtype AmbientDeclaration a = AmbientDeclaration { _ambientDeclarationBody :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 AmbientDeclaration where liftEq = genericLiftEq
instance Ord1 AmbientDeclaration where liftCompare = genericLiftCompare
@ -403,16 +434,19 @@ instance Show1 AmbientDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AmbientDeclaration where
eval (AmbientDeclaration body) = subtermValue body
data EnumDeclaration a = EnumDeclaration { _enumDeclarationIdentifier :: !a, _enumDeclarationBody :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, _enumDeclarationBody :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ExtendsClause where liftEq = genericLiftEq
instance Ord1 ExtendsClause where liftCompare = genericLiftCompare
@ -420,7 +454,7 @@ instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ExtendsClause
newtype ArrayType a = ArrayType { _arrayType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ArrayType where liftEq = genericLiftEq
instance Ord1 ArrayType where liftCompare = genericLiftCompare
@ -428,7 +462,7 @@ instance Show1 ArrayType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ArrayType
newtype FlowMaybeType a = FlowMaybeType { _flowMaybeType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 FlowMaybeType where liftEq = genericLiftEq
instance Ord1 FlowMaybeType where liftCompare = genericLiftCompare
@ -436,7 +470,7 @@ instance Show1 FlowMaybeType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable FlowMaybeType
newtype TypeQuery a = TypeQuery { _typeQuerySubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeQuery where liftEq = genericLiftEq
instance Ord1 TypeQuery where liftCompare = genericLiftCompare
@ -444,7 +478,7 @@ instance Show1 TypeQuery where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeQuery
newtype IndexTypeQuery a = IndexTypeQuery { _indexTypeQuerySubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 IndexTypeQuery where liftEq = genericLiftEq
instance Ord1 IndexTypeQuery where liftCompare = genericLiftCompare
@ -452,7 +486,7 @@ instance Show1 IndexTypeQuery where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IndexTypeQuery
newtype TypeArguments a = TypeArguments { _typeArguments :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 TypeArguments where liftEq = genericLiftEq
instance Ord1 TypeArguments where liftCompare = genericLiftCompare
@ -460,7 +494,7 @@ instance Show1 TypeArguments where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeArguments
newtype ThisType a = ThisType ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ThisType where liftEq = genericLiftEq
instance Ord1 ThisType where liftCompare = genericLiftCompare
@ -468,7 +502,7 @@ instance Show1 ThisType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ThisType
newtype ExistentialType a = ExistentialType ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ExistentialType where liftEq = genericLiftEq
instance Ord1 ExistentialType where liftCompare = genericLiftCompare
@ -476,7 +510,7 @@ instance Show1 ExistentialType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ExistentialType
newtype LiteralType a = LiteralType { _literalTypeSubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 LiteralType where liftEq = genericLiftEq
instance Ord1 LiteralType where liftCompare = genericLiftCompare
@ -484,7 +518,7 @@ instance Show1 LiteralType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable LiteralType
data PropertySignature a = PropertySignature { _modifiers :: ![a], _propertySignaturePropertyName :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 PropertySignature where liftEq = genericLiftEq
instance Ord1 PropertySignature where liftCompare = genericLiftCompare
@ -492,7 +526,7 @@ instance Show1 PropertySignature where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PropertySignature
data CallSignature a = CallSignature { _callSignatureTypeParameters :: !a, _callSignatureParameters :: ![a], _callSignatureType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 CallSignature where liftEq = genericLiftEq
instance Ord1 CallSignature where liftCompare = genericLiftCompare
@ -501,7 +535,7 @@ instance Evaluatable CallSignature
-- | Todo: Move type params and type to context
data ConstructSignature a = ConstructSignature { _constructSignatureTypeParameters :: !a, _constructSignatureParameters :: ![a], _constructSignatureType :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ConstructSignature where liftEq = genericLiftEq
instance Ord1 ConstructSignature where liftCompare = genericLiftCompare
@ -509,7 +543,7 @@ instance Show1 ConstructSignature where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ConstructSignature
data IndexSignature a = IndexSignature { _indexSignatureSubject :: a, _indexSignatureType :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 IndexSignature where liftEq = genericLiftEq
instance Ord1 IndexSignature where liftCompare = genericLiftCompare
@ -517,7 +551,7 @@ instance Show1 IndexSignature where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IndexSignature
data AbstractMethodSignature a = AbstractMethodSignature { _abstractMethodSignatureContext :: ![a], _abstractMethodSignatureName :: !a, _abstractMethodSignatureParameters :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 AbstractMethodSignature where liftEq = genericLiftEq
instance Ord1 AbstractMethodSignature where liftCompare = genericLiftCompare
@ -525,7 +559,7 @@ instance Show1 AbstractMethodSignature where liftShowsPrec = genericLiftShowsPre
instance Evaluatable AbstractMethodSignature
data Debugger a = Debugger
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Debugger where liftEq = genericLiftEq
instance Ord1 Debugger where liftCompare = genericLiftCompare
@ -533,7 +567,7 @@ instance Show1 Debugger where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Debugger
data ForOf a = ForOf { _forOfBinding :: !a, _forOfSubject :: !a, _forOfBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ForOf where liftEq = genericLiftEq
instance Ord1 ForOf where liftCompare = genericLiftCompare
@ -541,7 +575,7 @@ instance Show1 ForOf where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ForOf
data This a = This
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 This where liftEq = genericLiftEq
instance Ord1 This where liftCompare = genericLiftCompare
@ -549,7 +583,7 @@ instance Show1 This where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable This
data LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: !a, _labeledStatementSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 LabeledStatement where liftEq = genericLiftEq
instance Ord1 LabeledStatement where liftCompare = genericLiftCompare
@ -557,7 +591,7 @@ instance Show1 LabeledStatement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable LabeledStatement
newtype Update a = Update { _updateSubject :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Update where liftEq = genericLiftEq
instance Ord1 Update where liftCompare = genericLiftCompare
@ -565,7 +599,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Update
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Module where liftEq = genericLiftEq
instance Ord1 Module where liftCompare = genericLiftCompare
@ -575,12 +609,12 @@ instance Evaluatable Module where
eval (Module iden xs) = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
letrec' name $ \addr ->
eval xs <* makeNamespace name addr []
eval xs <* makeNamespace name addr Nothing
data InternalModule a = InternalModule { internalModuleIdentifier :: !a, internalModuleStatements :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 InternalModule where liftEq = genericLiftEq
instance Ord1 InternalModule where liftCompare = genericLiftCompare
@ -590,11 +624,14 @@ instance Evaluatable InternalModule where
eval (InternalModule iden xs) = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
letrec' name $ \addr ->
eval xs <* makeNamespace name addr []
eval xs <* makeNamespace name addr Nothing
instance Declarations a => Declarations (InternalModule a) where
declaredName InternalModule{..} = declaredName internalModuleIdentifier
data ImportAlias a = ImportAlias { _importAliasSubject :: !a, _importAlias :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ImportAlias where liftEq = genericLiftEq
instance Ord1 ImportAlias where liftCompare = genericLiftCompare
@ -602,7 +639,7 @@ instance Show1 ImportAlias where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImportAlias
data Super a = Super
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Super where liftEq = genericLiftEq
instance Ord1 Super where liftCompare = genericLiftCompare
@ -610,7 +647,7 @@ instance Show1 Super where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Super
data Undefined a = Undefined
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 Undefined where liftEq = genericLiftEq
instance Ord1 Undefined where liftCompare = genericLiftCompare
@ -618,23 +655,35 @@ instance Show1 Undefined where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Undefined
data ClassHeritage a = ClassHeritage { _classHeritageExtendsClause :: !a, _implementsClause :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
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 (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
data AbstractClass a = AbstractClass { abstractClassIdentifier :: !a, _abstractClassTypeParameters :: !a, classHeritage :: ![a], classBody :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 AbstractClass where liftEq = genericLiftEq
instance Ord1 AbstractClass where liftCompare = genericLiftCompare
instance Show1 AbstractClass where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AbstractClass
instance Declarations a => Declarations (AbstractClass a) where
declaredName AbstractClass{..} = declaredName abstractClassIdentifier
instance Evaluatable AbstractClass where
eval AbstractClass{..} = do
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm abstractClassIdentifier)
supers <- traverse subtermValue classHeritage
(v, addr) <- letrec name $ do
void $ subtermValue classBody
classEnv <- Env.head <$> getEnv
klass name supers classEnv
v <$ modifyEnv (Env.insert name addr)
data JsxElement a = JsxElement { _jsxOpeningElement :: !a, _jsxElements :: ![a], _jsxClosingElement :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JsxElement where liftEq = genericLiftEq
instance Ord1 JsxElement where liftCompare = genericLiftCompare
@ -642,7 +691,7 @@ instance Show1 JsxElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxElement
newtype JsxText a = JsxText ByteString
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JsxText where liftEq = genericLiftEq
instance Ord1 JsxText where liftCompare = genericLiftCompare
@ -650,7 +699,7 @@ instance Show1 JsxText where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxText
newtype JsxExpression a = JsxExpression { _jsxExpression :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JsxExpression where liftEq = genericLiftEq
instance Ord1 JsxExpression where liftCompare = genericLiftCompare
@ -658,7 +707,7 @@ instance Show1 JsxExpression where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxExpression
data JsxOpeningElement a = JsxOpeningElement { _jsxOpeningElementIdentifier :: !a, _jsxAttributes :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JsxOpeningElement where liftEq = genericLiftEq
instance Ord1 JsxOpeningElement where liftCompare = genericLiftCompare
@ -666,7 +715,7 @@ instance Show1 JsxOpeningElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxOpeningElement
newtype JsxClosingElement a = JsxClosingElement { _jsxClosingElementIdentifier :: a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JsxClosingElement where liftEq = genericLiftEq
instance Ord1 JsxClosingElement where liftCompare = genericLiftCompare
@ -674,7 +723,7 @@ instance Show1 JsxClosingElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxClosingElement
data JsxSelfClosingElement a = JsxSelfClosingElement { _jsxSelfClosingElementIdentifier :: !a, _jsxSelfClosingElementAttributes :: ![a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JsxSelfClosingElement where liftEq = genericLiftEq
instance Ord1 JsxSelfClosingElement where liftCompare = genericLiftCompare
@ -682,7 +731,7 @@ instance Show1 JsxSelfClosingElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxSelfClosingElement
data JsxAttribute a = JsxAttribute { _jsxAttributeTarget :: !a, _jsxAttributeValue :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JsxAttribute where liftEq = genericLiftEq
instance Ord1 JsxAttribute where liftCompare = genericLiftCompare
@ -690,7 +739,7 @@ instance Show1 JsxAttribute where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxAttribute
newtype ImplementsClause a = ImplementsClause { _implementsClauseTypes :: [a] }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 ImplementsClause where liftEq = genericLiftEq
instance Ord1 ImplementsClause where liftCompare = genericLiftCompare
@ -698,7 +747,7 @@ instance Show1 ImplementsClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImplementsClause
data OptionalParameter a = OptionalParameter { _optionalParameterContext :: ![a], _optionalParameterSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 OptionalParameter where liftEq = genericLiftEq
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
@ -706,7 +755,7 @@ instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable OptionalParameter
data RequiredParameter a = RequiredParameter { _requiredParameterContext :: ![a], _requiredParameterSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 RequiredParameter where liftEq = genericLiftEq
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
@ -714,7 +763,7 @@ instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RequiredParameter
data RestParameter a = RestParameter { _restParameterContext :: ![a], _restParameterSubject :: !a }
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 RestParameter where liftEq = genericLiftEq
instance Ord1 RestParameter where liftCompare = genericLiftCompare
@ -722,7 +771,7 @@ instance Show1 RestParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RestParameter
newtype JsxFragment a = JsxFragment [a]
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JsxFragment where liftEq = genericLiftEq
instance Ord1 JsxFragment where liftCompare = genericLiftCompare
@ -730,7 +779,7 @@ instance Show1 JsxFragment where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxFragment
data JsxNamespaceName a = JsxNamespaceName a a
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
instance Eq1 JsxNamespaceName where liftEq = genericLiftEq
instance Ord1 JsxNamespaceName where liftCompare = genericLiftCompare

72
src/Parsing/Parser.hs
View File

@ -2,8 +2,11 @@
module Parsing.Parser
( Parser(..)
, SomeParser(..)
, SomeAnalysisParser(..)
, someParser
, someAnalysisParser
, ApplyAll
, ApplyAll'
-- À la carte parsers
, goParser
, javaParser
@ -15,32 +18,69 @@ module Parsing.Parser
, phpParser
) where
import Prologue
import Assigning.Assignment
import Assigning.Assignment
import qualified CMarkGFM
import Data.AST
import Data.Kind
import Data.Language
import Data.Record
import Data.AST
import Data.Kind
import Data.Language
import Data.Record
import qualified Data.Syntax as Syntax
import Data.Term
import Foreign.Ptr
import Data.Term
import Data.File
import Foreign.Ptr
import qualified GHC.TypeLits as TypeLevel
import qualified Language.Go.Assignment as Go
import qualified Language.Java.Assignment as Java
import qualified Language.JSON.Assignment as JSON
import qualified Language.Markdown.Assignment as Markdown
import qualified Language.PHP.Assignment as PHP
import Language.Preluded
import qualified Language.Python.Assignment as Python
import qualified Language.Ruby.Assignment as Ruby
import qualified Language.TypeScript.Assignment as TypeScript
import qualified Language.PHP.Assignment as PHP
import Prologue
import TreeSitter.Go
import TreeSitter.JSON
import qualified TreeSitter.Language as TS (Language, Symbol)
import TreeSitter.Go
import TreeSitter.JSON
import TreeSitter.Java
import TreeSitter.PHP
import TreeSitter.Python
import TreeSitter.Ruby
import TreeSitter.TypeScript
import TreeSitter.Java
import TreeSitter.PHP
import TreeSitter.Python
import TreeSitter.Ruby
import TreeSitter.TypeScript
type family ApplyAll' (typeclasses :: [(* -> *) -> Constraint]) (fs :: [* -> *]) :: Constraint where
ApplyAll' (typeclass ': typeclasses) fs = (Apply typeclass fs, ApplyAll' typeclasses fs)
ApplyAll' '[] fs = ()
-- | A parser, suitable for program analysis, for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
data SomeAnalysisParser typeclasses ann where
SomeAnalysisParser :: ( Member Syntax.Identifier fs
, ApplyAll' typeclasses fs)
=> Parser (Term (Union fs) ann) -- ^ A parser.
-> Maybe File -- ^ Maybe path to prelude.
-> SomeAnalysisParser typeclasses ann
-- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax
, ApplyAll' typeclasses Java.Syntax
, ApplyAll' typeclasses PHP.Syntax
, ApplyAll' typeclasses Python.Syntax
, ApplyAll' typeclasses Ruby.Syntax
, ApplyAll' typeclasses TypeScript.Syntax
)
=> proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
-> Language -- ^ The 'Language' to select.
-> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced.
someAnalysisParser _ Go = SomeAnalysisParser goParser Nothing
someAnalysisParser _ Java = SomeAnalysisParser javaParser Nothing
someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser Nothing
someAnalysisParser _ PHP = SomeAnalysisParser phpParser Nothing
someAnalysisParser _ Python = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python))
someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby))
someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser Nothing
someAnalysisParser _ l = error $ "Analysis not supported for: " <> show l
-- | A parser from 'Source' onto some term type.
data Parser term where

14
src/Prologue.hs
View File

@ -3,7 +3,8 @@ module Prologue
( module X
, foldMapA
, maybeM
, maybeFail
, maybeLast
, fromMaybeLast
) where
@ -61,10 +62,13 @@ import GHC.Stack as X
foldMapA :: (Alternative m, Foldable t) => (b -> m a) -> t b -> m a
foldMapA f = getAlt . foldMap (Alt . f)
maybeLast :: Foldable t => b -> (a -> b) -> t a -> b
maybeLast b f = maybe b f . getLast . foldMap (Last . Just)
fromMaybeLast :: Foldable t => a -> t a -> a
fromMaybeLast b = fromMaybe b . getLast . foldMap (Last . Just)
-- | Extract the 'Just' of a 'Maybe' in an 'Applicative' context or, given 'Nothing', run the provided action.
maybeM :: Applicative f => f a -> Maybe a -> f a
maybeM f = maybe f pure
-- | Either extract the 'Just' of a 'Maybe' or invoke 'fail' with the provided string.
maybeFail :: MonadFail m => String -> Maybe a -> m a
maybeFail s = maybeM (X.fail s)

10
src/Rendering/Renderer.hs
View File

@ -2,6 +2,7 @@
module Rendering.Renderer
( DiffRenderer(..)
, TermRenderer(..)
, GraphRenderer(..)
, SomeRenderer(..)
, renderSExpressionDiff
, renderSExpressionTerm
@ -65,10 +66,17 @@ data TermRenderer output where
deriving instance Eq (TermRenderer output)
deriving instance Show (TermRenderer output)
-- | Specification of renderers for graph analysis, producing output in the parameter type.
data GraphRenderer output where
JSONGraphRenderer :: GraphRenderer ByteString
DOTGraphRenderer :: GraphRenderer ByteString
deriving instance Eq (GraphRenderer output)
deriving instance Show (GraphRenderer output)
-- | Abstraction of some renderer to some 'Monoid'al output which can be serialized to a 'ByteString'.
--
-- This type abstracts the type indices of 'DiffRenderer' and 'TermRenderer' s.t. multiple renderers can be present in a single list, alternation, etc., while retaining the ability to render and serialize. (Without 'SomeRenderer', the different output types of individual term/diff renderers prevent them from being used in a homogeneously typed setting.)
-- This type abstracts the type indices of 'DiffRenderer', 'TermRenderer', and 'GraphRenderer' s.t. multiple renderers can be present in a single list, alternation, etc., while retaining the ability to render and serialize. (Without 'SomeRenderer', the different output types of individual term/diff renderers prevent them from being used in a homogeneously typed setting.)
data SomeRenderer f where
SomeRenderer :: (Output output, Show (f output)) => f output -> SomeRenderer f

118
src/Semantic/CLI.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ApplicativeDo, TemplateHaskell #-}
module Semantic.CLI
( main
-- Testing
@ -6,33 +6,37 @@ module Semantic.CLI
, runParse
) where
import Prologue
import Data.Language
import Data.List (intercalate)
import Data.List.Split (splitWhen)
import Data.Version (showVersion)
import Development.GitRev
import Options.Applicative
import Rendering.Renderer
import Data.File
import Data.Language
import Data.List (intercalate)
import Data.List.Split (splitWhen)
import Data.Version (showVersion)
import Development.GitRev
import Options.Applicative
import qualified Paths_semantic as Library (version)
import Semantic.IO (languageForFilePath)
import Prologue
import Rendering.Renderer
import qualified Semantic.Diff as Semantic (diffBlobPairs)
import qualified Semantic.Graph as Semantic (graph)
import Semantic.IO (languageForFilePath)
import qualified Semantic.Log as Log
import qualified Semantic.Parse as Semantic (parseBlobs)
import qualified Semantic.Task as Task
import System.IO (Handle, stdin, stdout)
import Text.Read
import System.IO (Handle, stdin, stdout)
import Text.Read
main :: IO ()
main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.TaskEff ByteString
runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both File] -> Task.TaskEff ByteString
runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs
runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.TaskEff ByteString
runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff ByteString
runGraph (SomeRenderer r) rootDir dir excludeDirs = Semantic.graph r <=< Task.readProject rootDir dir excludeDirs
-- | A parser for the application's command-line arguments.
--
-- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
@ -43,54 +47,58 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")"
description = fullDesc <> header "semantic -- Parse and diff semantically"
optionsParser = Log.Options
<$> (not <$> switch (long "disable-colour" <> long "disable-color" <> help "Disable ANSI colors in log messages even if the terminal is a TTY."))
<*> options [("error", Just Log.Error), ("warning", Just Log.Warning), ("info", Just Log.Info), ("debug", Just Log.Debug), ("none", Nothing)]
(long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.")
<*> optional (strOption (long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id"))
-- The rest of the logging options are set automatically at runtime.
<*> pure False -- IsTerminal
<*> pure False -- PrintSource
<*> pure Log.logfmtFormatter -- Formatter
<*> pure 0 -- ProcessID
<*> switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
argumentsParser = (. Task.writeToOutput) . (>>=)
<$> hsubparser (diffCommand <> parseCommand)
<*> ( Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout")
<|> pure (Left stdout) )
optionsParser = do
disableColour <- not <$> switch (long "disable-colour" <> long "disable-color" <> help "Disable ANSI colors in log messages even if the terminal is a TTY.")
logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)]
(long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.")
requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id")
failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
pure $ Log.Options disableColour logLevel requestId False False Log.logfmtFormatter 0 failOnWarning
argumentsParser = do
subparser <- hsubparser (diffCommand <> parseCommand <> graphCommand)
output <- Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (Left stdout)
pure $ subparser >>= Task.writeToOutput output
diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths"))
diffArgumentsParser = runDiff
<$> ( flag (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree")
<|> flag' (SomeRenderer JSONDiffRenderer) (long "json" <> help "Output JSON diff trees")
<|> flag' (SomeRenderer ToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary")
<|> flag' (SomeRenderer DOTDiffRenderer) (long "dot" <> help "Output the diff as a DOT graph"))
<*> ( Right <$> some (both
<$> argument filePathReader (metavar "FILE_A")
<*> argument filePathReader (metavar "FILE_B"))
<|> pure (Left stdin) )
diffArgumentsParser = do
renderer <- flag (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree")
<|> flag' (SomeRenderer JSONDiffRenderer) (long "json" <> help "Output JSON diff trees")
<|> flag' (SomeRenderer ToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary")
<|> flag' (SomeRenderer DOTDiffRenderer) (long "dot" <> help "Output the diff as a DOT graph")
filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
pure $ runDiff renderer filesOrStdin
parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for path(s)"))
parseArgumentsParser = runParse
<$> ( flag (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
<|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees")
<|> flag' (SomeRenderer TagsTermRenderer) (long "tags" <> help "Output JSON tags")
<|> flag' (SomeRenderer . SymbolsTermRenderer) (long "symbols" <> help "Output JSON symbol list")
<*> ( option symbolFieldsReader ( long "fields"
<> help "Comma delimited list of specific fields to return (symbols output only)."
<> metavar "FIELDS")
parseArgumentsParser = do
renderer <- flag (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
<|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees")
<|> flag' (SomeRenderer TagsTermRenderer) (long "tags" <> help "Output JSON tags")
<|> flag' (SomeRenderer . SymbolsTermRenderer) (long "symbols" <> help "Output JSON symbol list")
<*> (option symbolFieldsReader ( long "fields"
<> help "Comma delimited list of specific fields to return (symbols output only)."
<> metavar "FIELDS")
<|> pure defaultSymbolFields)
<|> flag' (SomeRenderer ImportsTermRenderer) (long "import-graph" <> help "Output JSON import graph")
<|> flag' (SomeRenderer DOTTermRenderer) (long "dot" <> help "Output DOT graph parse trees"))
<*> ( Right <$> some (argument filePathReader (metavar "FILES..."))
<|> pure (Left stdin) )
<|> flag' (SomeRenderer ImportsTermRenderer) (long "import-graph" <> help "Output JSON import graph")
<|> flag' (SomeRenderer DOTTermRenderer) (long "dot" <> help "Output DOT graph parse trees")
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
pure $ runParse renderer filesOrStdin
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute an import graph a directory or entry point"))
graphArgumentsParser = do
renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)")
<|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph")
rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIRECTORY"))
excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)"))
File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE")
pure $ runGraph renderer rootDir filePath (fromJust fileLanguage) excludeDirs
filePathReader = eitherReader parseFilePath
parseFilePath arg = case splitWhen (== ':') arg of
[a, b] | Just lang <- readMaybe a -> Right (b, Just lang)
| Just lang <- readMaybe b -> Right (a, Just lang)
[path] -> Right (path, languageForFilePath path)
_ -> Left ("cannot parse `" <> arg <> "`\nexpecting LANGUAGE:FILE or just FILE")
[a, b] | lang <- readMaybe b -> Right (File a lang)
| lang <- readMaybe a -> Right (File b lang)
[path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path . Just) (languageForFilePath path)
args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE")
optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options)
options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options)))

101
src/Semantic/Graph.hs Normal file
View File

@ -0,0 +1,101 @@
{-# LANGUAGE GADTs #-}
module Semantic.Graph where
import Analysis.Abstract.BadAddresses
import Analysis.Abstract.BadModuleResolutions
import Analysis.Abstract.BadSyntax
import Analysis.Abstract.BadValues
import Analysis.Abstract.BadVariables
import Analysis.Abstract.Erroring
import Analysis.Abstract.Evaluating
import Analysis.Abstract.ImportGraph
import qualified Control.Exception as Exc
import Data.Abstract.Address
import qualified Data.Abstract.Evaluatable as Analysis
import Data.Abstract.FreeVariables
import Data.Abstract.Located
import Data.Abstract.Module
import Data.Abstract.Package as Package
import Data.Abstract.Value (Value)
import Data.File
import Data.Output
import qualified Data.Syntax as Syntax
import Data.Term
import Parsing.Parser
import Prologue hiding (MonadError (..))
import Rendering.Renderer
import Semantic.IO (Files)
import Semantic.Task
graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs
=> GraphRenderer output
-> Project
-> Eff effs ByteString
graph renderer project
| SomeAnalysisParser parser prelude <- someAnalysisParser
(Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
parsePackage parser prelude project >>= graphImports >>= case renderer of
JSONGraphRenderer -> pure . toOutput
DOTGraphRenderer -> pure . renderImportGraph
-- | Parse a list of files into a 'Package'.
parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
=> Parser term -- ^ A parser.
-> Maybe File -- ^ Prelude (optional).
-> Project -- ^ Project to parse into a package.
-> Eff effs (Package term)
parsePackage parser preludeFile project@Project{..} = do
prelude <- traverse (parseModule parser Nothing) preludeFile
p <- parseModules parser project
trace ("project: " <> show p) $ pure (Package.fromModules n Nothing prelude (length projectEntryPoints) p)
where
n = name (projectName project)
-- | Parse all files in a project into 'Module's.
parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> Project -> Eff effs [Module term]
parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir))
-- | Parse a file into a 'Module'.
parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> File -> Eff effs (Module term)
parseModule parser rootDir file = do
blob <- readBlob file
moduleForBlob rootDir blob <$> parse parser blob
type ImportGraphAnalysis term
= ImportGraphing
( BadAddresses
( BadModuleResolutions
( BadVariables
( BadValues
( BadSyntax
( Erroring (Analysis.LoadError term)
( Evaluating
(Located Precise term)
term
(Value (Located Precise term)))))))))
-- | Render the import graph for a given 'Package'.
graphImports :: ( Show ann
, Ord ann
, Apply Analysis.Declarations1 syntax
, Apply Analysis.Evaluatable syntax
, Apply FreeVariables1 syntax
, Apply Functor syntax
, Apply Ord1 syntax
, Apply Eq1 syntax
, Apply Show1 syntax
, Member Syntax.Identifier syntax
, Members '[Exc SomeException, Task] effs
)
=> Package (Term (Union syntax) ann) -> Eff effs ImportGraph
graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph
where
asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value
-> Package term
-> ImportGraphAnalysis term effs value
asAnalysisForTypeOfPackage = const
extractGraph result = case result of
(Right (Right ((_, graph), _)), _) -> pure graph
_ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))

90
src/Semantic/IO.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TupleSections, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.IO
( readFile
, readFilePair
@ -6,9 +6,13 @@ module Semantic.IO
, readBlobPairsFromHandle
, readBlobsFromHandle
, readBlobsFromPaths
, readProjectFromPaths
, readBlobsFromDir
, findFiles
, languageForFilePath
, NoLanguageForBlob(..)
, readBlob
, readProject
, readBlobs
, readBlobPairs
, writeToOutput
@ -25,6 +29,7 @@ import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.Blob as Blob
import Data.Bool
import Data.File
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Language
@ -32,6 +37,8 @@ import Data.Source
import Prelude hiding (readFile)
import Prologue hiding (MonadError (..), fail)
import System.Directory (doesDirectoryExist)
import qualified System.Directory.Tree as Tree
import System.Directory.Tree (AnchoredDirTree(..))
import System.Exit
import System.FilePath
import System.FilePath.Glob
@ -39,16 +46,16 @@ import System.IO (Handle)
import Text.Read
-- | Read a utf8-encoded file to a 'Blob'.
readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m (Maybe Blob.Blob)
readFile "/dev/null" _ = pure Nothing
readFile path language = do
readFile :: forall m. MonadIO m => File -> m (Maybe Blob.Blob)
readFile (File "/dev/null" _) = pure Nothing
readFile (File path language) = do
raw <- liftIO (Just <$> B.readFile path)
pure $ Blob.sourceBlob path language . fromBytes <$> raw
readFilePair :: forall m. MonadIO m => (FilePath, Maybe Language) -> (FilePath, Maybe Language) -> m Blob.BlobPair
readFilePair :: forall m. MonadIO m => File -> File -> m Blob.BlobPair
readFilePair a b = do
before <- uncurry readFile a
after <- uncurry readFile b
before <- readFile a
after <- readFile b
case (before, after) of
(Just a, Nothing) -> pure (Join (This a))
(Nothing, Just b) -> pure (Join (That b))
@ -75,14 +82,56 @@ readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob]
readBlobsFromHandle = fmap toBlobs . readFromHandle
where toBlobs BlobParse{..} = fmap toBlob blobs
readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob]
readBlobsFromPaths files = catMaybes <$> traverse (uncurry readFile) files
readBlobFromPath :: MonadIO m => File -> m Blob.Blob
readBlobFromPath file = do
maybeFile <- readFile file
maybe (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) pure maybeFile
readBlobsFromPaths :: MonadIO m => [File] -> m [Blob.Blob]
readBlobsFromPaths files = catMaybes <$> traverse readFile files
readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
readProjectFromPaths maybeRoot path lang excludeDirs = do
isDir <- isDirectory path
let (filterFun, entryPoints, rootDir) = if isDir
then (id, [], fromMaybe path maybeRoot)
else (filter (/= path), [toFile path], fromMaybe (takeDirectory path) maybeRoot)
paths <- liftIO $ filterFun <$> findFiles rootDir exts excludeDirs
pure $ Project rootDir (toFile <$> paths) lang entryPoints
where
toFile path = File path (Just lang)
exts = extensionsForLanguage lang
-- Recursively find files in a directory.
findFiles :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
findFiles path exts excludeDirs = do
_:/dir <- liftIO $ Tree.build path
pure $ (onlyFiles . Tree.filterDir (withExtensions exts) . Tree.filterDir (notIn excludeDirs)) dir
where
-- Build a list of only FilePath's (remove directories and failures)
onlyFiles (Tree.Dir _ fs) = concatMap onlyFiles fs
onlyFiles (Tree.Failed _ _) = []
onlyFiles (Tree.File _ f) = [f]
-- Predicate for Files with one of the extensions in 'exts'.
withExtensions exts (Tree.File n _)
| takeExtension n `elem` exts = True
| otherwise = False
withExtensions _ _ = True
-- Predicate for contents NOT in a directory
notIn dirs (Tree.Dir n _)
| (x:_) <- n, x == '.' = False -- Don't include directories that start with '.'.
| n `elem` dirs = False
| otherwise = True
notIn _ _ = True
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
readBlobsFromDir path = do
paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
let paths' = catMaybes $ fmap (\p -> (p,) . Just <$> languageForFilePath p) paths
blobs <- traverse (uncurry readFile) paths'
let paths' = catMaybes $ fmap (\p -> File p . Just <$> languageForFilePath p) paths
blobs <- traverse readFile paths'
pure (catMaybes blobs)
readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a
@ -129,15 +178,20 @@ instance FromJSON BlobPair where
newtype NoLanguageForBlob = NoLanguageForBlob FilePath
deriving (Eq, Exception, Ord, Show, Typeable)
readBlob :: Member Files effs => File -> Eff effs Blob.Blob
readBlob = send . ReadBlob
-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
readBlobs :: Member Files effs => Either Handle [(FilePath, Maybe Language)] -> Eff effs [Blob.Blob]
readBlobs :: Member Files effs => Either Handle [File] -> Eff effs [Blob.Blob]
readBlobs = send . ReadBlobs
-- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
readBlobPairs :: Member Files effs => Either Handle [Both (FilePath, Maybe Language)] -> Eff effs [Blob.BlobPair]
readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair]
readBlobPairs = send . ReadBlobPairs
readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
-- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs ()
writeToOutput path = send . WriteToOutput path
@ -145,17 +199,21 @@ writeToOutput path = send . WriteToOutput path
-- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's.
data Files out where
ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> Files [Blob.Blob]
ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Files [Blob.BlobPair]
ReadBlob :: File -> Files Blob.Blob
ReadBlobs :: Either Handle [File] -> Files [Blob.Blob]
ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair]
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project
WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
-- | Run a 'Files' effect in 'IO'.
runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a
runFiles = interpret $ \ files -> case files of
ReadBlob path -> rethrowing (readBlobFromPath path)
ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle)
ReadBlobs (Right paths@[(path, Nothing)]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
ReadBlobs (Right paths@[File path _]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)
ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)

2
src/Semantic/Log.hs
View File

@ -68,7 +68,7 @@ terminalFormatter :: Options -> Message -> String
terminalFormatter Options{..} (Message level message pairs time) =
showChar '[' . showTime time . showString "] "
. showLevel level . showChar ' '
. showString (printf "%-20s" message)
. showString (printf "%-20s " message)
. showPairs pairs
. showChar '\n' $ ""
where

56
src/Semantic/Task.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
module Semantic.Task
( Task
, TaskEff
@ -7,8 +7,10 @@ module Semantic.Task
, RAlgebra
, Differ
-- * I/O
, IO.readBlob
, IO.readBlobs
, IO.readBlobPairs
, IO.readProject
, IO.writeToOutput
-- * Telemetry
, writeLog
@ -16,14 +18,10 @@ module Semantic.Task
, time
-- * High-level flow
, parse
, parseModule
, parseModules
, parsePackage
, analyze
, decorate
, diff
, render
, graphImports
-- * Concurrency
, distribute
, distributeFor
@ -45,26 +43,15 @@ module Semantic.Task
, Telemetry
) where
import qualified Analysis.Abstract.ImportGraph as Abstract
import Analysis.Abstract.Evaluating
import Analysis.Decorator (decoratorWithAlgebra)
import qualified Assigning.Assignment as Assignment
import qualified Control.Abstract.Analysis as Analysis
import qualified Control.Exception as Exc
import Control.Monad
import Control.Monad.Effect.Exception
import Control.Monad.Effect.Internal as Eff hiding (run)
import Control.Monad.Effect.Reader
import Control.Monad.Effect.Run as Run
import Data.Abstract.Address
import qualified Data.Abstract.Evaluatable as Analysis
import Data.Abstract.FreeVariables
import Data.Abstract.Located
import Data.Abstract.Module
import Data.Abstract.Package as Package
import Data.Abstract.Value (Value)
import Data.Blob
import qualified Data.ByteString as B
import Data.Diff
import qualified Data.Error as Error
import Data.Record
@ -73,7 +60,7 @@ import Data.Term
import Parsing.CMark
import Parsing.Parser
import Parsing.TreeSitter
import Prologue hiding (MonadError(..))
import Prologue hiding (MonadError (..))
import Semantic.Distribute
import qualified Semantic.IO as IO
import Semantic.Log
@ -100,23 +87,8 @@ type Renderer i o = i -> o
parse :: Member Task effs => Parser term -> Blob -> Eff effs term
parse parser = send . Parse parser
-- | Parse a file into a 'Module'.
parseModule :: Members '[IO.Files, Task] effs => Parser term -> Maybe FilePath -> FilePath -> Eff effs (Module term)
parseModule parser rootDir path = do
blob <- head <$> IO.readBlobs (Right [(path, IO.languageForFilePath path)])
moduleForBlob rootDir blob <$> parse parser blob
-- | Parse a list of files into 'Module's.
parseModules :: Members '[IO.Files, Task] effs => Parser term -> FilePath -> [FilePath] -> Eff effs [Module term]
parseModules parser rootDir = traverse (parseModule parser (Just rootDir))
-- | Parse a list of files into a 'Package'.
parsePackage :: Members '[IO.Files, Task] effs => PackageName -> Parser term -> FilePath -> [FilePath] -> Eff effs (Package term)
parsePackage name parser rootDir paths = Package (PackageInfo name Nothing) . Package.fromModules <$> parseModules parser rootDir paths
-- | A task running some 'Analysis.MonadAnalysis' to completion.
analyze :: Member Task effs => Analysis.SomeAnalysis m result -> Eff effs result
analyze :: (Analysis.Interpreter m analysisEffects, Member Task effs) => m analysisEffects result -> Eff effs (Analysis.Result m analysisEffects result)
analyze = send . Analyze
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
@ -131,18 +103,6 @@ diff differ term1 term2 = send (Semantic.Task.Diff differ term1 term2)
render :: Member Task effs => Renderer input output -> input -> Eff effs output
render renderer = send . Render renderer
-- | Render and serialize the import graph for a given 'Package'.
graphImports :: (Apply Eq1 syntax, Apply Analysis.Evaluatable syntax, Apply FreeVariables1 syntax, Apply Functor syntax, Apply Ord1 syntax, Apply Show1 syntax, Member Syntax.Identifier syntax, Members '[Exc SomeException, Task] effs, Ord ann, Show ann) => Package (Term (Union syntax) ann) -> Eff effs B.ByteString
graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= renderGraph
where asAnalysisForTypeOfPackage :: Abstract.ImportGraphing (Evaluating (Located Precise term) term (Value (Located Precise term))) effects value -> Package term -> Abstract.ImportGraphing (Evaluating (Located Precise term) term (Value (Located Precise term))) effects value
asAnalysisForTypeOfPackage = const
renderGraph result = case result of
(Right (Right (Right (Right (Right (Right (_, graph)))))), _) -> pure $! Abstract.renderImportGraph graph
_ -> throwError (toException (Exc.ErrorCall "graphImports: import graph rendering failed"))
-- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
--
-- > runTask = runTaskWithOptions defaultOptions
@ -171,7 +131,7 @@ runTaskWithOptions options task = do
-- | An effect describing high-level tasks to be performed.
data Task output where
Parse :: Parser term -> Blob -> Task term
Analyze :: Analysis.SomeAnalysis m result -> Task result
Analyze :: Analysis.Interpreter m effects => m effects result -> Task (Analysis.Result m effects result)
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
Render :: Renderer input output -> input -> Task output
@ -180,7 +140,7 @@ data Task output where
runTaskF :: Members '[Reader Options, Telemetry, Exc SomeException, IO] effs => Eff (Task ': effs) a -> Eff effs a
runTaskF = interpret $ \ task -> case task of
Parse parser blob -> runParser blob parser
Analyze analysis -> pure (Analysis.runSomeAnalysis analysis)
Analyze analysis -> pure (Analysis.interpret analysis)
Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2)
Render renderer input -> pure (renderer input)
@ -197,11 +157,13 @@ runParser blob@Blob{..} parser = case parser of
time "parse.tree_sitter_ast_parse" languageTag $
IO.rethrowing (parseToAST language blob)
AssignmentParser parser assignment -> do
traceM ("Parsing " <> blobPath)
ast <- runParser blob parser `catchError` \ (SomeException err) -> do
writeStat (Stat.increment "parse.parse_failures" languageTag)
writeLog Error "failed parsing" (("task", "parse") : blobFields)
throwError (toException err)
options <- ask
traceM ("Assigning " <> blobPath)
time "parse.assign" languageTag $
case Assignment.assign blobSource assignment ast of
Left err -> do

199
src/Semantic/Util.hs
View File

@ -1,148 +1,91 @@
-- MonoLocalBinds is to silence a warning about a simplifiable constraint.
{-# LANGUAGE DataKinds, MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Semantic.Util where
import Analysis.Abstract.BadVariables
import Analysis.Abstract.BadModuleResolutions
import Analysis.Abstract.BadValues
import Analysis.Abstract.Caching
import Analysis.Abstract.Quiet
import Analysis.Abstract.Dead
import Analysis.Abstract.Evaluating as X
import Analysis.Abstract.ImportGraph
import Analysis.Abstract.Tracing
import Analysis.Declaration
import Control.Abstract.Analysis
import Control.Monad.IO.Class
import Data.Abstract.Evaluatable hiding (head)
import Data.Abstract.Address
import Data.Abstract.Located
import Data.Abstract.Module
import Data.Abstract.Package as Package
import Data.Abstract.Type
import Data.Abstract.Value
import Data.Blob
import Data.Diff
import Data.Range
import Data.Record
import Data.Span
import Data.Term
import Diffing.Algorithm
import Diffing.Interpreter
import System.FilePath.Glob
import Analysis.Abstract.BadAddresses
import Analysis.Abstract.BadModuleResolutions
import Analysis.Abstract.BadSyntax
import Analysis.Abstract.BadValues
import Analysis.Abstract.BadVariables
import Analysis.Abstract.Caching
import Analysis.Abstract.Collecting
import Analysis.Abstract.Erroring
import Analysis.Abstract.Evaluating as X
import Analysis.Abstract.TypeChecking
import Control.Abstract.Analysis
import Data.Abstract.Address
import Data.Abstract.Evaluatable
import Data.Abstract.Located
import Data.Abstract.Type
import Data.Abstract.Value
import Data.Blob
import Data.File
import qualified Data.Language as Language
import qualified GHC.TypeLits as TypeLevel
import Language.Preluded
import Parsing.Parser
import Prologue
import Semantic.Diff (diffTermPair)
import Semantic.IO as IO
import Semantic.Task hiding (parsePackage)
import qualified Semantic.Task as Task
import System.FilePath.Posix
import Language.Preluded
import Parsing.Parser
import Prologue
import Semantic.Graph
import Semantic.IO as IO
import Semantic.Task
import qualified Language.Go.Assignment as Go
import qualified Language.PHP.Assignment as PHP
import qualified Language.Python.Assignment as Python
import qualified Language.Ruby.Assignment as Ruby
import qualified Language.TypeScript.Assignment as TypeScript
-- Ruby
evalRubyProject = runEvaluatingWithPrelude rubyParser ["rb"]
evalRubyFile path = runEvaluating <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluateModule <$> parseFile rubyParser Nothing path))
type JustEvaluating term
= Erroring (AddressError (Located Precise term) (Value (Located Precise term)))
( Erroring (EvalError (Value (Located Precise term)))
( Erroring (ResolutionError (Value (Located Precise term)))
( Erroring (Unspecialized (Value (Located Precise term)))
( Erroring (ValueError (Located Precise term) (Value (Located Precise term)))
( Erroring (LoadError term)
( Evaluating (Located Precise term) term (Value (Located Precise term))))))))
evalRubyProjectGraph path = runAnalysis @(ImportGraphing (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))))))) <$> (withPrelude <$> parsePrelude rubyParser <*> (evaluatePackageBody <$> parseProject rubyParser ["rb"] path))
type EvaluatingWithHoles term
= BadAddresses
( BadModuleResolutions
( BadVariables
( BadValues
( BadSyntax
( Erroring (LoadError term)
( Evaluating (Located Precise term) term (Value (Located Precise term))))))))
evalRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating (Located Precise Ruby.Term) Ruby.Term (Value (Located Precise Ruby.Term)))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
-- The order is significant here: Caching has to come on the outside, or its Interpreter instance
-- will expect the TypeError exception type to have an Ord instance, which is wrong.
type Checking term
= Caching
( TypeChecking
( Erroring (AddressError Monovariant Type)
( Erroring (EvalError Type)
( Erroring (ResolutionError Type)
( Erroring (Unspecialized Type)
( Erroring (LoadError term)
( Retaining
( Evaluating Monovariant term Type))))))))
evalRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Precise Ruby.Term (Value Precise))) . evaluateModules <$> parseFiles rubyParser (dropFileName (head paths)) paths
evalGoProject path = interpret @(JustEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path
evalRubyProject path = interpret @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
evalPHPProject path = interpret @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path
evalPythonProject path = interpret @(JustEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path
evalTypeScriptProjectQuietly path = interpret @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
evalTypeScriptProject path = interpret @(JustEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
-- Go
evalGoProject path = runEvaluating . evaluatePackageBody <$> parseProject goParser ["go"] path
evalGoFile path = runEvaluating . evaluateModule <$> parseFile goParser Nothing path
typecheckGoFile path = interpret @(Checking Go.Term) <$> evaluateProject goParser Language.Go Nothing path
typecheckGoFile path = runAnalysis @(Caching (Evaluating Monovariant Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path
rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Language.Ruby)
pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python)
-- Python
evalPythonProject = runEvaluatingWithPrelude pythonParser ["py"]
evalPythonFile path = runEvaluating <$> (withPrelude <$> parsePrelude pythonParser <*> (evaluateModule <$> parseFile pythonParser Nothing path))
-- Evaluate a project, starting at a single entrypoint.
evaluateProject parser lang prelude path = evaluatePackage <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude)
evalPythonImportGraph name paths = runAnalysis @(ImportGraphing (Evaluating (Located Precise Python.Term) Python.Term (Value (Located Precise Python.Term)))) . evaluatePackage <$> parsePackage name pythonParser (dropFileName (head paths)) paths
typecheckPythonFile path = runAnalysis @(Caching (Evaluating Monovariant Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path
tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Precise Python.Term (Value Precise))) . evaluateModule <$> parseFile pythonParser Nothing path
evalDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Precise Python.Term (Value Precise)))) . evaluateModule <$> parseFile pythonParser Nothing path
-- PHP
evalPHPProject path = runEvaluating . evaluatePackageBody <$> parseProject phpParser ["php"] path
evalPHPFile path = runEvaluating . evaluateModule <$> parseFile phpParser Nothing path
-- TypeScript
evalTypeScriptProject path = runEvaluating . evaluatePackageBody <$> parseProject typescriptParser ["ts", "tsx"] path
evalTypeScriptFile path = runEvaluating . evaluateModule <$> parseFile typescriptParser Nothing path
typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating Monovariant TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path
runEvaluatingWithPrelude parser exts path = runEvaluating <$> (withPrelude <$> parsePrelude parser <*> (evaluatePackageBody <$> parseProject parser exts path))
-- TODO: Remove this by exporting EvaluatingEffects
runEvaluating :: forall term effects a.
( Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) ~ effects
, Corecursive term
, Recursive term )
=> Evaluating Precise term (Value Precise) effects a
-> Final effects a
runEvaluating = runAnalysis @(Evaluating Precise term (Value Precise))
parsePrelude :: forall term. TypeLevel.KnownSymbol (PreludePath term) => Parser term -> IO (Module term)
parsePrelude parser = do
let preludePath = TypeLevel.symbolVal (Proxy :: Proxy (PreludePath term))
parseFile parser Nothing preludePath
parseProject :: Parser term
-> [Prelude.String]
-> FilePath
-> IO (PackageBody term)
parseProject parser exts entryPoint = do
let rootDir = takeDirectory entryPoint
paths <- getPaths exts rootDir
modules <- parseFiles parser rootDir paths
pure $ fromModulesWithEntryPoint modules (takeFileName entryPoint)
withPrelude prelude a = do
preludeEnv <- evaluateModule prelude *> getEnv
withDefaultEnvironment preludeEnv a
getPaths exts = fmap fold . globDir (compile . mappend "**/*." <$> exts)
evalRubyFile path = interpret @(JustEvaluating Ruby.Term) <$> evaluateFile rubyParser path
evaluateFile parser path = evaluateModule <$> runTask (parseModule parser Nothing (file path))
-- Read and parse a file.
parseFile :: Parser term -> Maybe FilePath -> FilePath -> IO (Module term)
parseFile parser rootDir path = runTask $ do
blob <- file path
moduleForBlob rootDir blob <$> parse parser blob
parseFile :: Parser term -> FilePath -> IO term
parseFile parser = runTask . (parse parser <=< readBlob . file)
parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term]
parseFiles parser rootDir = traverse (parseFile parser (Just rootDir))
parsePackage :: PackageName -> Parser term -> FilePath -> [FilePath] -> IO (Package term)
parsePackage name parser rootDir = runTask . Task.parsePackage name parser rootDir
-- Read a file from the filesystem into a Blob.
file :: MonadIO m => FilePath -> m Blob
file path = fromJust <$> IO.readFile path (languageForFilePath path)
-- Diff helpers
diffWithParser :: ( HasField fields Data.Span.Span
, HasField fields Range
, Eq1 syntax
, Show1 syntax
, Traversable syntax
, Diffable syntax
, GAlign syntax
, HasDeclaration syntax
, Members '[Distribute WrappedTask, Task] effs
)
=> Parser (Term syntax (Record fields))
-> BlobPair
-> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= diffTermPair diffTerms . runJoin
blob :: FilePath -> IO Blob
blob = runTask . readBlob . file

5
test/Analysis/Go/Spec.hs
View File

@ -1,6 +1,10 @@
{-# LANGUAGE OverloadedLists #-}
module Analysis.Go.Spec (spec) where
import Data.Abstract.Evaluatable (EvalError(..), interpret)
import qualified Language.Go.Assignment as Go
import qualified Data.Language as Language
import SpecHelpers
@ -28,3 +32,4 @@ spec = parallel $ do
where
fixtures = "test/fixtures/go/analysis/"
evaluate entry = evalGoProject (fixtures <> entry)
evalGoProject path = interpret @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path

5
test/Analysis/PHP/Spec.hs
View File

@ -1,6 +1,10 @@
{-# LANGUAGE OverloadedLists #-}
module Analysis.PHP.Spec (spec) where
import Data.Abstract.Evaluatable (EvalError(..), interpret)
import qualified Language.PHP.Assignment as PHP
import qualified Data.Language as Language
import SpecHelpers
@ -32,3 +36,4 @@ spec = parallel $ do
where
fixtures = "test/fixtures/php/analysis/"
evaluate entry = evalPHPProject (fixtures <> entry)
evalPHPProject path = interpret @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path

8
test/Analysis/Python/Spec.hs
View File

@ -1,8 +1,11 @@
{-# LANGUAGE OverloadedLists, OverloadedStrings #-}
module Analysis.Python.Spec (spec) where
import Data.Abstract.Evaluatable (EvalError(..), interpret)
import Data.Abstract.Value
import Data.Map
import qualified Language.Python.Assignment as Python
import qualified Data.Language as Language
import SpecHelpers
@ -37,14 +40,15 @@ spec = parallel $ do
it "subclasses" $ do
v <- fst <$> evaluate "subclass.py"
v `shouldBe` Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\""))))))))
v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\"")))))))))
it "handles multiple inheritance left-to-right" $ do
v <- fst <$> evaluate "multiple_inheritance.py"
v `shouldBe` Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\""))))))))
v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\"")))))))))
where
ns n = Just . Latest . Just . injValue . Namespace n
addr = Address . Precise
fixtures = "test/fixtures/python/analysis/"
evaluate entry = evalPythonProject (fixtures <> entry)
evalPythonProject path = interpret @(TestEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path

30
test/Analysis/Ruby/Spec.hs
View File

@ -2,12 +2,15 @@
module Analysis.Ruby.Spec (spec) where
import Data.Abstract.Evaluatable (EvalError(..))
import Data.Abstract.Value
import Data.Abstract.Evaluatable
import Data.Abstract.Value as Value
import Data.Abstract.Number as Number
import Control.Monad.Effect (SomeExc(..))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map
import Data.Map.Monoidal as Map
import qualified Language.Ruby.Assignment as Ruby
import qualified Data.Language as Language
import SpecHelpers
@ -32,7 +35,7 @@ spec = parallel $ do
it "evaluates subclass" $ do
res <- evaluate "subclass.rb"
fst res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<bar>\"")))))))
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<bar>\"")))))))))
environment (snd res) `shouldBe` [ ("Bar", addr 6)
, ("Foo", addr 3)
, ("Object", addr 0) ]
@ -44,16 +47,33 @@ spec = parallel $ do
it "evaluates modules" $ do
res <- evaluate "modules.rb"
fst res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<hello>\"")))))))
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<hello>\"")))))))))
environment (snd res) `shouldBe` [ ("Object", addr 0)
, ("Bar", addr 3) ]
it "handles break correctly" $ do
res <- evaluate "break.rb"
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 3))))))))))
it "handles break correctly" $ do
res <- evaluate "next.rb"
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 8))))))))))
it "calls functions with arguments" $ do
res <- evaluate "call.rb"
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 579))))))))))
it "evaluates early return statements" $ do
res <- evaluate "early-return.rb"
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 123))))))))))
it "has prelude" $ do
res <- fst <$> evaluate "preluded.rb"
res `shouldBe` Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"<foo>\"")))))))
res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<foo>\"")))))))))
where
ns n = Just . Latest . Just . injValue . Namespace n
addr = Address . Precise
fixtures = "test/fixtures/ruby/analysis/"
evaluate entry = evalRubyProject (fixtures <> entry)
evalRubyProject path = interpret @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path

16
test/Analysis/TypeScript/Spec.hs
View File

@ -1,8 +1,13 @@
{-# LANGUAGE OverloadedLists #-}
module Analysis.TypeScript.Spec (spec) where
import SpecHelpers
import Data.Abstract.Evaluatable
import qualified Language.TypeScript.Assignment as TypeScript
import Data.Abstract.Value as Value
import Data.Abstract.Number as Number
import qualified Data.Language as Language
import SpecHelpers
spec :: Spec
spec = parallel $ do
@ -25,12 +30,17 @@ spec = parallel $ do
it "side effect only imports" $ do
env <- environment . snd <$> evaluate "main2.ts"
env `shouldBe` mempty
env `shouldBe` emptyEnv
it "fails exporting symbols not defined in the module" $ do
v <- fst <$> evaluate "bad-export.ts"
v `shouldBe` Left "module \"foo.ts\" does not export \"pip\""
v `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc (ExportError "foo.ts" (Name "pip"))))))))
it "evaluates early return statements" $ do
res <- evaluate "early-return.ts"
fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Float (Number.Decimal 123.0))))))))))
where
fixtures = "test/fixtures/typescript/analysis/"
evaluate entry = evalTypeScriptProject (fixtures <> entry)
evalTypeScriptProject path = interpret @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path

4
test/Assigning/Assignment/Spec.hs
View File

@ -188,13 +188,13 @@ spec = do
it "advances past the current node" $
snd <$> runAssignment "hi" source (makeState [ node Red 0 2 [] ])
`shouldBe`
Right (State 2 (Pos 1 3) [] [])
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) [] [])
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 []]])

20
test/Data/Abstract/Path/Spec.hs Normal file
View File

@ -0,0 +1,20 @@
module Data.Abstract.Path.Spec(spec) where
import Data.Abstract.Path
import SpecHelpers
spec :: Spec
spec = parallel $
describe "joinPaths" $ do
it "joins empty paths" $
joinPaths "" "" `shouldBe` "."
it "joins relative paths" $
joinPaths "a/b" "./c" `shouldBe` "a/b/c"
it "joins absolute paths" $
joinPaths "/a/b" "c" `shouldBe` "/a/b/c"
it "walks up directories for ../" $
joinPaths "a/b" "../c" `shouldBe` "a/c"
it "walks up directories for multiple ../" $
joinPaths "a/b" "../../c" `shouldBe` "c"
it "stops walking at top directory" $
joinPaths "a/b" "../../../c" `shouldBe` "c"

21
test/Integration/Spec.hs
View File

@ -1,27 +1,22 @@
module Integration.Spec (spec) where
import Data.Foldable (find, traverse_)
import Data.Foldable (find, traverse_, for_)
import Data.List (union, concat, transpose)
import qualified Data.ByteString as B
import System.FilePath.Glob
import System.FilePath.Posix
import SpecHelpers
languages :: [FilePath]
languages = ["go", "javascript", "python", "ruby", "typescript"]
spec :: Spec
spec = parallel $ do
it "lists example fixtures" $ do
examples "test/fixtures/go/" `shouldNotReturn` []
examples "test/fixtures/javascript/" `shouldNotReturn` []
examples "test/fixtures/python/" `shouldNotReturn` []
examples "test/fixtures/ruby/" `shouldNotReturn` []
examples "test/fixtures/typescript/" `shouldNotReturn` []
describe "go" $ runTestsIn "test/fixtures/go/" []
describe "javascript" $ runTestsIn "test/fixtures/javascript/" []
describe "python" $ runTestsIn "test/fixtures/python/" []
describe "ruby" $ runTestsIn "test/fixtures/ruby/" []
describe "typescript" $ runTestsIn "test/fixtures/typescript/" []
for_ languages $ \language -> do
let dir = "test/fixtures" </> language </> "corpus"
it (language <> " corpus exists") $ examples dir `shouldNotReturn` []
describe (language <> " corpus") $ runTestsIn dir []
where
runTestsIn :: FilePath -> [(FilePath, String)] -> SpecWith ()

4
test/Matching/Go/Spec.hs
View File

@ -30,11 +30,11 @@ loopMatcher = target <* go where
spec :: Spec
spec = describe "matching/go" $ do
it "extracts integers" $ do
parsed <- moduleBody <$> parseFile goParser Nothing "test/fixtures/go/matching/integers.go"
parsed <- parseFile goParser "test/fixtures/go/matching/integers.go"
let matched = runMatcher integerMatcher parsed
sort matched `shouldBe` ["1", "2", "3"]
it "counts for loops" $ do
parsed <- moduleBody <$> parseFile goParser Nothing "test/fixtures/go/matching/for.go"
parsed <- parseFile goParser "test/fixtures/go/matching/for.go"
let matched = runMatcher @[] loopMatcher parsed
length matched `shouldBe` 2

60
test/Rendering/TOC/Spec.hs
View File

@ -1,16 +1,24 @@
{-# LANGUAGE DataKinds, TypeOperators #-}
{-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators #-}
module Rendering.TOC.Spec (spec) where
import Analysis.Declaration
import Data.Aeson
import Data.Align.Generic
import Data.Bifunctor
import Data.Bifunctor.Join
import Data.Diff
import Data.Functor.Classes
import Data.Patch
import Data.Range
import Data.Record
import Data.Span
import Data.Term
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Union
import Diffing.Algorithm
import Diffing.Interpreter
import Prelude hiding (readFile)
import Prelude
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import Rendering.TOC
@ -44,7 +52,7 @@ spec = parallel $ do
diffTOC blankDiff `shouldBe` [ ]
it "summarizes changed methods" $ do
sourceBlobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb")
sourceBlobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.B.rb")
diff <- runTask $ diffWithParser rubyParser sourceBlobs
diffTOC diff `shouldBe`
[ TOCSummary "Method" "self.foo" (Span (Pos 1 1) (Pos 2 4)) "added"
@ -53,7 +61,7 @@ spec = parallel $ do
]
it "summarizes changed classes" $ do
sourceBlobs <- blobsForPaths (both "ruby/classes.A.rb" "ruby/classes.B.rb")
sourceBlobs <- blobsForPaths (both "ruby/toc/classes.A.rb" "ruby/toc/classes.B.rb")
diff <- runTask $ diffWithParser rubyParser sourceBlobs
diffTOC diff `shouldBe`
[ TOCSummary "Class" "Baz" (Span (Pos 1 1) (Pos 2 4)) "removed"
@ -62,37 +70,37 @@ spec = parallel $ do
]
it "dedupes changes in same parent method" $ do
sourceBlobs <- blobsForPaths (both "javascript/duplicate-parent.A.js" "javascript/duplicate-parent.B.js")
sourceBlobs <- blobsForPaths (both "javascript/toc/duplicate-parent.A.js" "javascript/toc/duplicate-parent.B.js")
diff <- runTask $ diffWithParser typescriptParser sourceBlobs
diffTOC diff `shouldBe`
[ TOCSummary "Function" "myFunction" (Span (Pos 1 1) (Pos 6 2)) "modified" ]
it "dedupes similar methods" $ do
sourceBlobs <- blobsForPaths (both "javascript/erroneous-duplicate-method.A.js" "javascript/erroneous-duplicate-method.B.js")
sourceBlobs <- blobsForPaths (both "javascript/toc/erroneous-duplicate-method.A.js" "javascript/toc/erroneous-duplicate-method.B.js")
diff <- runTask $ diffWithParser typescriptParser sourceBlobs
diffTOC diff `shouldBe`
[ TOCSummary "Function" "performHealthCheck" (Span (Pos 8 1) (Pos 29 2)) "modified" ]
it "summarizes Go methods with receivers with special formatting" $ do
sourceBlobs <- blobsForPaths (both "go/method-with-receiver.A.go" "go/method-with-receiver.B.go")
sourceBlobs <- blobsForPaths (both "go/toc/method-with-receiver.A.go" "go/toc/method-with-receiver.B.go")
diff <- runTask $ diffWithParser goParser sourceBlobs
diffTOC diff `shouldBe`
[ TOCSummary "Method" "(*apiClient) CheckAuth" (Span (Pos 3 1) (Pos 3 101)) "added" ]
it "summarizes Ruby methods that start with two identifiers" $ do
sourceBlobs <- blobsForPaths (both "ruby/method-starts-with-two-identifiers.A.rb" "ruby/method-starts-with-two-identifiers.B.rb")
sourceBlobs <- blobsForPaths (both "ruby/toc/method-starts-with-two-identifiers.A.rb" "ruby/toc/method-starts-with-two-identifiers.B.rb")
diff <- runTask $ diffWithParser rubyParser sourceBlobs
diffTOC diff `shouldBe`
[ TOCSummary "Method" "foo" (Span (Pos 1 1) (Pos 4 4)) "modified" ]
it "handles unicode characters in file" $ do
sourceBlobs <- blobsForPaths (both "ruby/unicode.A.rb" "ruby/unicode.B.rb")
sourceBlobs <- blobsForPaths (both "ruby/toc/unicode.A.rb" "ruby/toc/unicode.B.rb")
diff <- runTask $ diffWithParser rubyParser sourceBlobs
diffTOC diff `shouldBe`
[ TOCSummary "Method" "foo" (Span (Pos 6 1) (Pos 7 4)) "added" ]
it "properly slices source blob that starts with a newline and has multi-byte chars" $ do
sourceBlobs <- blobsForPaths (both "javascript/starts-with-newline.js" "javascript/starts-with-newline.js")
sourceBlobs <- blobsForPaths (both "javascript/toc/starts-with-newline.js" "javascript/toc/starts-with-newline.js")
diff <- runTask $ diffWithParser rubyParser sourceBlobs
diffTOC diff `shouldBe` []
@ -135,24 +143,24 @@ spec = parallel $ do
describe "diff with ToCDiffRenderer'" $ do
it "produces JSON output" $ do
blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb")
blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.B.rb")
output <- runTask (diffBlobPair ToCDiffRenderer blobs)
toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n" :: ByteString)
toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n" :: ByteString)
it "produces JSON output if there are parse errors" $ do
blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.X.rb")
blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.X.rb")
output <- runTask (diffBlobPair ToCDiffRenderer blobs)
toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
it "ignores anonymous functions" $ do
blobs <- blobsForPaths (both "ruby/lambda.A.rb" "ruby/lambda.B.rb")
blobs <- blobsForPaths (both "ruby/toc/lambda.A.rb" "ruby/toc/lambda.B.rb")
output <- runTask (diffBlobPair ToCDiffRenderer blobs)
toOutput output `shouldBe` ("{\"changes\":{},\"errors\":{}}\n" :: ByteString)
it "summarizes Markdown headings" $ do
blobs <- blobsForPaths (both "markdown/headings.A.md" "markdown/headings.B.md")
blobs <- blobsForPaths (both "markdown/toc/headings.A.md" "markdown/toc/headings.B.md")
output <- runTask (diffBlobPair ToCDiffRenderer blobs)
toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[1,1],\"end\":[3,16]},\"category\":\"Heading 1\",\"term\":\"Introduction\",\"changeType\":\"removed\"},{\"span\":{\"start\":[5,1],\"end\":[7,4]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"modified\"},{\"span\":{\"start\":[9,1],\"end\":[11,10]},\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"changeType\":\"added\"},{\"span\":{\"start\":[13,1],\"end\":[14,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/markdown/toc/headings.A.md -> test/fixtures/markdown/toc/headings.B.md\":[{\"span\":{\"start\":[1,1],\"end\":[3,16]},\"category\":\"Heading 1\",\"term\":\"Introduction\",\"changeType\":\"removed\"},{\"span\":{\"start\":[5,1],\"end\":[7,4]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"modified\"},{\"span\":{\"start\":[9,1],\"end\":[11,10]},\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"changeType\":\"added\"},{\"span\":{\"start\":[13,1],\"end\":[14,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
type Diff' = Diff ListableSyntax (Record '[Maybe Declaration, Range, Span]) (Record '[Maybe Declaration, Range, Span])
@ -215,10 +223,26 @@ isMethodOrFunction a
| otherwise = False
blobsForPaths :: Both FilePath -> IO BlobPair
blobsForPaths = readFilePair . fmap ("test/fixtures/toc/" <>)
blobsForPaths = readFilePair . fmap ("test/fixtures" </>)
blankDiff :: Diff'
blankDiff = merge (arrayInfo, arrayInfo) (inj [ inserting (termIn literalInfo (inj (Syntax.Identifier (name "\"a\"")))) ])
where
arrayInfo = Nothing :. Range 0 3 :. Span (Pos 1 1) (Pos 1 5) :. Nil
literalInfo = Nothing :. Range 1 2 :. Span (Pos 1 2) (Pos 1 4) :. Nil
-- Diff helpers
diffWithParser :: ( HasField fields Data.Span.Span
, HasField fields Range
, Eq1 syntax
, Show1 syntax
, Traversable syntax
, Diffable syntax
, GAlign syntax
, HasDeclaration syntax
, Members '[Distribute WrappedTask, Task] effs
)
=> Parser (Term syntax (Record fields))
-> BlobPair
-> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= diffTermPair diffTerms . runJoin

30
test/Semantic/CLI/Spec.hs
View File

@ -26,34 +26,34 @@ spec = parallel $ do
when (actual /= expected) $ print actual
actual `shouldBe` expected
parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [(FilePath, Maybe Language)], ByteString)]
parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [File], ByteString)]
parseFixtures =
[ (SomeRenderer SExpressionTermRenderer, pathMode, sExpressionParseTreeOutput)
, (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput)
, (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput')
, (SomeRenderer JSONTermRenderer, Right [], emptyJsonParseTreeOutput)
, (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)], symbolsOutput)
, (SomeRenderer TagsTermRenderer, Right [("test/fixtures/ruby/method-declaration.A.rb", Just Ruby)], tagsOutput)
, (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], symbolsOutput)
, (SomeRenderer TagsTermRenderer, Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], tagsOutput)
]
where pathMode = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby)]
pathMode' = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/and-or.B.rb", Just Ruby)]
where pathMode = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby)]
pathMode' = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby), File "test/fixtures/ruby/corpus/and-or.B.rb" (Just Ruby)]
sExpressionParseTreeOutput = "(Program\n (LowAnd\n (Identifier)\n (Identifier)))\n"
jsonParseTreeOutput = "{\"trees\":[{\"path\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]}\n"
jsonParseTreeOutput' = "{\"trees\":[{\"path\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"LowAnd\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"b\",\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"c\",\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]}\n"
sExpressionParseTreeOutput = "(Program\n (LowAnd\n (Send\n (Identifier))\n (Send\n (Identifier))))\n"
jsonParseTreeOutput = "{\"trees\":[{\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]}\n"
jsonParseTreeOutput' = "{\"trees\":[{\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/corpus/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"LowAnd\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}}],\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"b\",\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"c\",\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]}\n"
emptyJsonParseTreeOutput = "{\"trees\":[]}\n"
symbolsOutput = "{\"files\":[{\"path\":\"test/fixtures/ruby/method-declaration.A.rb\",\"symbols\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"kind\":\"Method\",\"symbol\":\"foo\"}],\"language\":\"Ruby\"}]}\n"
tagsOutput = "[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"path\":\"test/fixtures/ruby/method-declaration.A.rb\",\"kind\":\"Method\",\"symbol\":\"foo\",\"line\":\"def foo\",\"language\":\"Ruby\"}]\n"
symbolsOutput = "{\"files\":[{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"symbols\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"kind\":\"Method\",\"symbol\":\"foo\"}],\"language\":\"Ruby\"}]}\n"
tagsOutput = "[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"kind\":\"Method\",\"symbol\":\"foo\",\"line\":\"def foo\",\"language\":\"Ruby\"}]\n"
diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both (FilePath, Maybe Language)], ByteString)]
diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both File], ByteString)]
diffFixtures =
[ (SomeRenderer JSONDiffRenderer, pathMode, jsonOutput)
, (SomeRenderer SExpressionDiffRenderer, pathMode, sExpressionOutput)
, (SomeRenderer ToCDiffRenderer, pathMode, tocOutput)
]
where pathMode = Right [both ("test/fixtures/ruby/method-declaration.A.rb", Just Ruby) ("test/fixtures/ruby/method-declaration.B.rb", Just Ruby)]
where pathMode = Right [both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)) (File "test/fixtures/ruby/corpus/method-declaration.B.rb" (Just Ruby))]
jsonOutput = "{\"diffs\":[{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"stat\":{\"replace\":[{\"path\":\"test/fixtures/ruby/method-declaration.A.rb\",\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/method-declaration.B.rb\",\"language\":\"Ruby\"}],\"path\":\"test/fixtures/ruby/method-declaration.A.rb -> test/fixtures/ruby/method-declaration.B.rb\"}}]}\n"
sExpressionOutput = "(Program\n (Method\n (Empty)\n { (Identifier)\n ->(Identifier) }\n {+(Identifier)+}\n (\n {+(Identifier)+})))\n"
tocOutput = "{\"changes\":{\"test/fixtures/ruby/method-declaration.A.rb -> test/fixtures/ruby/method-declaration.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"}]},\"errors\":{}}\n"
jsonOutput = "{\"diffs\":[{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Send\",\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"stat\":{\"replace\":[{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/corpus/method-declaration.B.rb\",\"language\":\"Ruby\"}],\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb -> test/fixtures/ruby/corpus/method-declaration.B.rb\"}}]}\n"
sExpressionOutput = "(Program\n (Method\n (Empty)\n { (Identifier)\n ->(Identifier) }\n {+(Identifier)+}\n (\n {+(Send\n {+(Identifier)+})+})))\n"
tocOutput = "{\"changes\":{\"test/fixtures/ruby/corpus/method-declaration.A.rb -> test/fixtures/ruby/corpus/method-declaration.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"}]},\"errors\":{}}\n"

28
test/Semantic/IO/Spec.hs
View File

@ -12,67 +12,67 @@ spec :: Spec
spec = parallel $ do
describe "readFile" $ do
it "returns a blob for extant files" $ do
Just blob <- readFile "semantic.cabal" Nothing
Just blob <- readFile (File "semantic.cabal" Nothing)
blobPath blob `shouldBe` "semantic.cabal"
it "throws for absent files" $ do
readFile "this file should not exist" Nothing `shouldThrow` anyIOException
readFile (File "this file should not exist" Nothing) `shouldThrow` anyIOException
describe "readBlobPairsFromHandle" $ do
let a = sourceBlob "method.rb" (Just Ruby) "def foo; end"
let b = sourceBlob "method.rb" (Just Ruby) "def bar(x); end"
it "returns blobs for valid JSON encoded diff input" $ do
blobs <- blobsFromFilePath "test/fixtures/input/diff.json"
blobs <- blobsFromFilePath "test/fixtures/cli/diff.json"
blobs `shouldBe` [blobPairDiffing a b]
it "returns blobs when there's no before" $ do
blobs <- blobsFromFilePath "test/fixtures/input/diff-no-before.json"
blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-before.json"
blobs `shouldBe` [blobPairInserting b]
it "returns blobs when there's null before" $ do
blobs <- blobsFromFilePath "test/fixtures/input/diff-null-before.json"
blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-before.json"
blobs `shouldBe` [blobPairInserting b]
it "returns blobs when there's no after" $ do
blobs <- blobsFromFilePath "test/fixtures/input/diff-no-after.json"
blobs <- blobsFromFilePath "test/fixtures/cli/diff-no-after.json"
blobs `shouldBe` [blobPairDeleting a]
it "returns blobs when there's null after" $ do
blobs <- blobsFromFilePath "test/fixtures/input/diff-null-after.json"
blobs <- blobsFromFilePath "test/fixtures/cli/diff-null-after.json"
blobs `shouldBe` [blobPairDeleting a]
it "returns blobs for unsupported language" $ do
h <- openFile "test/fixtures/input/diff-unsupported-language.json" ReadMode
h <- openFile "test/fixtures/cli/diff-unsupported-language.json" ReadMode
blobs <- readBlobPairsFromHandle h
let b' = sourceBlob "test.kt" Nothing "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
blobs `shouldBe` [blobPairInserting b']
it "detects language based on filepath for empty language" $ do
blobs <- blobsFromFilePath "test/fixtures/input/diff-empty-language.json"
blobs <- blobsFromFilePath "test/fixtures/cli/diff-empty-language.json"
blobs `shouldBe` [blobPairDiffing a b]
it "throws on blank input" $ do
h <- openFile "test/fixtures/input/blank.json" ReadMode
h <- openFile "test/fixtures/cli/blank.json" ReadMode
readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
it "throws if language field not given" $ do
h <- openFile "test/fixtures/input/diff-no-language.json" ReadMode
h <- openFile "test/fixtures/cli/diff-no-language.json" ReadMode
readBlobsFromHandle h `shouldThrow` (== ExitFailure 1)
it "throws if null on before and after" $ do
h <- openFile "test/fixtures/input/diff-null-both-sides.json" ReadMode
h <- openFile "test/fixtures/cli/diff-null-both-sides.json" ReadMode
readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
describe "readBlobsFromHandle" $ do
it "returns blobs for valid JSON encoded parse input" $ do
h <- openFile "test/fixtures/input/parse.json" ReadMode
h <- openFile "test/fixtures/cli/parse.json" ReadMode
blobs <- readBlobsFromHandle h
let a = sourceBlob "method.rb" (Just Ruby) "def foo; end"
blobs `shouldBe` [a]
it "throws on blank input" $ do
h <- openFile "test/fixtures/input/blank.json" ReadMode
h <- openFile "test/fixtures/cli/blank.json" ReadMode
readBlobsFromHandle h `shouldThrow` (== ExitFailure 1)
where blobsFromFilePath path = do

2
test/Spec.hs
View File

@ -7,6 +7,7 @@ import qualified Analysis.Ruby.Spec
import qualified Analysis.TypeScript.Spec
import qualified Assigning.Assignment.Spec
import qualified Data.Diff.Spec
import qualified Data.Abstract.Path.Spec
import qualified Data.Functor.Classes.Generic.Spec
import qualified Data.Mergeable.Spec
import qualified Data.Scientific.Spec
@ -35,6 +36,7 @@ main = hspec $ do
describe "Analysis.TypeScript" Analysis.TypeScript.Spec.spec
describe "Assigning.Assignment" Assigning.Assignment.Spec.spec
describe "Data.Diff" Data.Diff.Spec.spec
describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
describe "Data.Mergeable" Data.Mergeable.Spec.spec
describe "Data.Scientific" Data.Scientific.Spec.spec

32
test/SpecHelpers.hs
View File

@ -1,22 +1,29 @@
{-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
module SpecHelpers (
module X
module SpecHelpers
( module X
, diffFilePaths
, parseFilePath
, readFilePair
, readFileVerbatim
, addr
, ns
, verbatim
, Verbatim(..)
, ) where
, TestEvaluating
) where
import Analysis.Abstract.Evaluating as X (EvaluatingState(..))
import Analysis.Abstract.Erroring
import Analysis.Abstract.Evaluating
import Control.Abstract.Addressable
import Control.Abstract.Evaluator as X (EvaluatorState(..))
import Control.Abstract.Value
import Data.Abstract.Address as X
import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables as X hiding (dropExtension)
import Data.Abstract.Heap as X
import Data.Abstract.ModuleTable as X hiding (lookup)
import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue)
import Data.Blob as X
import Data.File as X
import Data.Functor.Listable as X
import Data.Language as X
import Data.Output as X
@ -47,7 +54,6 @@ import Test.LeanCheck as X
import qualified Data.ByteString as B
import qualified Semantic.IO as IO
import Data.Abstract.Value
-- | Returns an s-expression formatted diff for the specified FilePath pair.
diffFilePaths :: Both FilePath -> IO ByteString
@ -55,15 +61,21 @@ diffFilePaths paths = readFilePair paths >>= runTask . diffBlobPair SExpressionD
-- | Returns an s-expression parse tree for the specified FilePath.
parseFilePath :: FilePath -> IO ByteString
parseFilePath path = (fromJust <$> IO.readFile path (IO.languageForFilePath path)) >>= runTask . parseBlob SExpressionTermRenderer
parseFilePath path = (fromJust <$> IO.readFile (file path)) >>= runTask . parseBlob SExpressionTermRenderer
-- | Read two files to a BlobPair.
readFilePair :: Both FilePath -> IO BlobPair
readFilePair paths = let paths' = fmap (\p -> (p, IO.languageForFilePath p)) paths in
readFilePair paths = let paths' = fmap file paths in
runBothWith IO.readFilePair paths'
readFileVerbatim :: FilePath -> IO Verbatim
readFileVerbatim = fmap verbatim . B.readFile
type TestEvaluating term
= Erroring (AddressError Precise (Value Precise))
( Erroring (EvalError (Value Precise))
( Erroring (ResolutionError (Value Precise))
( Erroring (Unspecialized (Value Precise))
( Erroring (ValueError Precise (Value Precise))
( Erroring (LoadError term)
( Evaluating Precise term (Value Precise)))))))
ns n = Just . Latest . Just . injValue . Namespace n
addr = Address . Precise

0
test/fixtures/input/blank.json → test/fixtures/cli/blank.json vendored
View File

0
test/fixtures/input/diff-empty-language.json → test/fixtures/cli/diff-empty-language.json vendored
View File

0
test/fixtures/input/diff-no-after.json → test/fixtures/cli/diff-no-after.json vendored
View File

0
test/fixtures/input/diff-no-before.json → test/fixtures/cli/diff-no-before.json vendored
View File

0
test/fixtures/input/diff-no-language.json → test/fixtures/cli/diff-no-language.json vendored
View File

0
test/fixtures/input/diff-null-after.json → test/fixtures/cli/diff-null-after.json vendored
View File

0
test/fixtures/input/diff-null-before.json → test/fixtures/cli/diff-null-before.json vendored
View File

0
test/fixtures/input/diff-null-both-sides.json → test/fixtures/cli/diff-null-both-sides.json vendored
View File

Some files were not shown because too many files have changed in this diff Show More