diff --git a/semantic.cabal b/semantic.cabal index 7d8a91c71..d42c54c09 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -83,7 +83,6 @@ library , Data.Language , Data.Map.Monoidal , Data.Mergeable - , Data.Options , Data.Patch , Data.Project , Data.Range @@ -249,9 +248,9 @@ library , StrictData , TypeApplications if flag(release) - ghc-options: -Wall -Werror -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O1 -j + ghc-options: -Wall -Werror -Wmissing-export-lists -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O1 -j else - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O0 -j + ghc-options: -Wall -Wmissing-export-lists -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-name-shadowing -O0 -j ghc-prof-options: -fprof-auto executable semantic diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 481f50a1d..a9ded9d3f 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -125,8 +125,8 @@ scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address (Cell scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value) -caching :: (Alternative f, Effects effects) => TermEvaluator term address value (NonDet ': Reader (Cache term address (Cell address) value) ': State (Cache term address (Cell address) value) ': effects) a -> TermEvaluator term address value effects (Cache term address (Cell address) value, f a) +caching :: Effects effects => TermEvaluator term address value (NonDet ': Reader (Cache term address (Cell address) value) ': State (Cache term address (Cell address) value) ': effects) a -> TermEvaluator term address value effects (Cache term address (Cell address) value, [a]) caching = runState lowerBound . runReader lowerBound - . runNonDetA + . runNonDet diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 5d5640845..aae5252c5 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -47,12 +47,12 @@ style = (defaultStyle (T.encodeUtf8Builder . vertexName)) -- | Add vertices to the graph for evaluated identifiers. graphingTerms :: ( Element Syntax.Identifier syntax , Member (Reader ModuleInfo) effects - , Member (Env (Hole (Located address))) effects + , Member (Env (Hole context (Located address))) effects , Member (State (Graph Vertex)) effects , Base term ~ TermF (Sum syntax) ann ) - => SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a) - -> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a) + => SubtermAlgebra (Base term) term (TermEvaluator term (Hole context (Located address)) value effects a) + -> SubtermAlgebra (Base term) term (TermEvaluator term (Hole context (Located address)) value effects a) graphingTerms recur term@(In _ syntax) = do case project syntax of Just (Syntax.Identifier name) -> do @@ -128,11 +128,11 @@ moduleInclusion v = do appendGraph (vertex (moduleVertex m) `connect` vertex v) -- | Add an edge from the passed variable name to the module it originated within. -variableDefinition :: ( Member (Env (Hole (Located address))) effects +variableDefinition :: ( Member (Env (Hole context (Located address))) effects , Member (State (Graph Vertex)) effects ) => Name - -> TermEvaluator term (Hole (Located address)) value effects () + -> TermEvaluator term (Hole context (Located address)) value effects () variableDefinition name = do graph <- maybe lowerBound (maybe lowerBound (vertex . moduleVertex . addressModule) . toMaybe) <$> TermEvaluator (lookupEnv name) appendGraph (vertex (Variable (formatName name)) `connect` graph) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 530b1f1c5..993f3d417 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -54,15 +54,15 @@ instance (Allocatable address effects, Member (Reader ModuleInfo) effects, Membe instance Derefable address effects => Derefable (Located address) effects where derefCell (Located loc _ _) = relocate . derefCell loc -instance Addressable address effects => Addressable (Hole address) effects where - type Cell (Hole address) = Cell address +instance (Addressable address effects, Ord context, Show context) => Addressable (Hole context address) effects where + type Cell (Hole context address) = Cell address -instance Allocatable address effects => Allocatable (Hole address) effects where +instance (Allocatable address effects, Ord context, Show context) => Allocatable (Hole context address) effects where allocCell name = relocate (Total <$> allocCell name) -instance Derefable address effects => Derefable (Hole address) effects where +instance (Derefable address effects, Ord context, Show context) => Derefable (Hole context address) effects where derefCell (Total loc) = relocate . derefCell loc - derefCell Partial = const (pure Nothing) + derefCell (Partial _) = const (pure Nothing) relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a relocate = raiseEff . lowerEff diff --git a/src/Control/Abstract/Hole.hs b/src/Control/Abstract/Hole.hs index 04ada8531..ccbb83eb6 100644 --- a/src/Control/Abstract/Hole.hs +++ b/src/Control/Abstract/Hole.hs @@ -1,15 +1,21 @@ -module Control.Abstract.Hole where +module Control.Abstract.Hole + ( AbstractHole (..) + , Hole (..) + , toMaybe + ) where + +import Prologue class AbstractHole a where hole :: a -data Hole a = Partial | Total a +data Hole context a = Partial context | Total a deriving (Foldable, Functor, Eq, Ord, Show, Traversable) -instance AbstractHole (Hole a) where - hole = Partial +instance Lower context => AbstractHole (Hole context a) where + hole = Partial lowerBound -toMaybe :: Hole a -> Maybe a -toMaybe Partial = Nothing -toMaybe (Total a) = Just a +toMaybe :: Hole context a -> Maybe a +toMaybe (Partial _) = Nothing +toMaybe (Total a) = Just a diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 6163d0bcb..4e5b29f11 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -1,4 +1,11 @@ -module Control.Abstract.Primitive where +module Control.Abstract.Primitive + ( define + , defineClass + , defineNamespace + , builtInPrint + , builtInExport + , lambda + ) where import Control.Abstract.Context import Control.Abstract.Environment diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index ff8fdeefc..c31d0725a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -124,6 +124,9 @@ class (AbstractFunction address value effects, AbstractIntro value) => AbstractV -- | Eliminate boolean values. TODO: s/boolean/truthy ifthenelse :: value -> Evaluator address value effects a -> Evaluator address value effects a -> Evaluator address value effects a + -- | Compute the disjunction (boolean or) of two computed values. This should have short-circuiting semantics where applicable. + disjunction :: Evaluator address value effects value -> Evaluator address value effects value -> Evaluator address value effects value + -- | @index x i@ computes @x[i]@, with zero-indexing. index :: value -> value -> Evaluator address value effects address diff --git a/src/Data/AST.hs b/src/Data/AST.hs index 38af9fc15..79e0e8c62 100644 --- a/src/Data/AST.hs +++ b/src/Data/AST.hs @@ -1,5 +1,10 @@ {-# LANGUAGE DataKinds #-} -module Data.AST where +module Data.AST + ( Node (..) + , AST + , Location + , nodeLocation + ) where import Data.Range import Data.Record diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index cb87676fb..b9205a51a 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -1,5 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} -module Data.Abstract.Address where +module Data.Abstract.Address + ( Precise (..) + , Located (..) + , Latest (..) + , All (..) + , Monovariant (..) + ) where import Data.Abstract.Module (ModuleInfo) import Data.Abstract.Name diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 78bd3ab25..0696016b7 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -1,5 +1,13 @@ {-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} -module Data.Abstract.Cache where +module Data.Abstract.Cache + ( Cache + , Cached (..) + , Cacheable + , cacheLookup + , cacheSet + , cacheInsert + , cacheKeys + ) where import Data.Abstract.Configuration import Data.Abstract.Heap diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index 0d2f89471..7c5ca44ee 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -1,4 +1,4 @@ -module Data.Abstract.Configuration where +module Data.Abstract.Configuration ( Configuration (..) ) where import Data.Abstract.Environment import Data.Abstract.Heap diff --git a/src/Data/Abstract/Declarations.hs b/src/Data/Abstract/Declarations.hs index b304f146b..494db37e0 100644 --- a/src/Data/Abstract/Declarations.hs +++ b/src/Data/Abstract/Declarations.hs @@ -1,5 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-} -module Data.Abstract.Declarations where +module Data.Abstract.Declarations + ( Declarations (..) + , Declarations1 (..) + ) where import Data.Abstract.Name import Data.Sum diff --git a/src/Data/Abstract/FreeVariables.hs b/src/Data/Abstract/FreeVariables.hs index 80a96e2e8..0010904e2 100644 --- a/src/Data/Abstract/FreeVariables.hs +++ b/src/Data/Abstract/FreeVariables.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DefaultSignatures, GeneralizedNewtypeDeriving, UndecidableInstances #-} -module Data.Abstract.FreeVariables where +module Data.Abstract.FreeVariables + ( FreeVariables (..) + , FreeVariables1 (..) + ) where import Data.Abstract.Name import Data.Sum diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index 6fbd7cc19..956be461f 100644 --- a/src/Data/Abstract/Heap.hs +++ b/src/Data/Abstract/Heap.hs @@ -1,5 +1,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.Abstract.Heap where +module Data.Abstract.Heap + ( Heap + , heapLookup + , heapLookupAll + , heapInsert + , heapInit + , heapSize + , heapRestrict + ) where import Data.Abstract.Live import qualified Data.Map.Monoidal as Monoidal diff --git a/src/Data/Abstract/Live.hs b/src/Data/Abstract/Live.hs index af922f17f..b7140ecda 100644 --- a/src/Data/Abstract/Live.hs +++ b/src/Data/Abstract/Live.hs @@ -1,5 +1,15 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-} -module Data.Abstract.Live where +module Data.Abstract.Live + ( Live (..) + , fromAddresses + , liveSingleton + , liveInsert + , liveDelete + , liveDifference + , liveMember + , liveSplit + , liveMap + ) where import Data.Set as Set import Prologue diff --git a/src/Data/Abstract/Package.hs b/src/Data/Abstract/Package.hs index 38136f0c9..529599b16 100644 --- a/src/Data/Abstract/Package.hs +++ b/src/Data/Abstract/Package.hs @@ -1,4 +1,9 @@ -module Data.Abstract.Package where +module Data.Abstract.Package + ( Package (..) + , PackageInfo (..) + , PackageName + , Data.Abstract.Package.fromModules + ) where import Data.Abstract.Module import Data.Abstract.ModuleTable as ModuleTable diff --git a/src/Data/Abstract/Path.hs b/src/Data/Abstract/Path.hs index 54faa28c1..47b96ec2b 100644 --- a/src/Data/Abstract/Path.hs +++ b/src/Data/Abstract/Path.hs @@ -1,4 +1,8 @@ -module Data.Abstract.Path where +module Data.Abstract.Path + ( dropRelativePrefix + , joinPaths + , stripQuotes + ) where import Prologue import qualified Data.Text as T diff --git a/src/Data/Abstract/Ref.hs b/src/Data/Abstract/Ref.hs index 96e38ae79..72cad84f9 100644 --- a/src/Data/Abstract/Ref.hs +++ b/src/Data/Abstract/Ref.hs @@ -1,5 +1,8 @@ {-# LANGUAGE GADTs #-} -module Data.Abstract.Ref where +module Data.Abstract.Ref + ( ValueRef (..) + , Ref (..) + ) where import Data.Abstract.Name diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index dc46cd3cb..e8b9533e6 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, UndecidableInstances #-} -module Data.Abstract.Value.Abstract where +module Data.Abstract.Value.Abstract ( Abstract (..) ) where import Control.Abstract import Data.Abstract.Environment as Env @@ -69,6 +69,7 @@ instance ( Member (Allocator address Abstract) effects index _ _ = box Abstract ifthenelse _ if' else' = if' <|> else' + disjunction = (<|>) liftNumeric _ _ = pure Abstract liftNumeric2 _ _ _ = pure Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 1c8e78907..4d95ab356 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -1,5 +1,13 @@ {-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances, LambdaCase #-} -module Data.Abstract.Value.Concrete where +module Data.Abstract.Value.Concrete + ( Value (..) + , ValueError (..) + , ClosureBody (..) + , materializeEnvironment + , runValueError + , runValueErrorWith + , throwValueError + ) where import Control.Abstract import Data.Abstract.Environment (Environment, Bindings) @@ -162,6 +170,11 @@ instance ( Coercible body (Eff effects) bool <- case cond of { Boolean b -> pure b ; _ -> throwValueError (BoolError cond) } if bool then if' else else' + disjunction a b = do + a' <- a + ifthenelse a' (pure a') b + + index = go where tryIdx list ii | ii > genericLength list = box =<< throwValueError (BoundsError list ii) diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 40a7afdde..1fd617408 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -295,6 +295,9 @@ instance ( Member (Allocator address Type) effects box (Var field) ifthenelse cond if' else' = unify cond Bool *> (if' <|> else') + disjunction a b = do + a' <- a + unify a' Bool *> (pure a' <|> b) liftNumeric _ = unify (Int :+ Float :+ Rational) liftNumeric2 _ left right = case (left, right) of diff --git a/src/Data/Graph/Vertex.hs b/src/Data/Graph/Vertex.hs index c42071cd9..98d997e81 100644 --- a/src/Data/Graph/Vertex.hs +++ b/src/Data/Graph/Vertex.hs @@ -6,14 +6,14 @@ module Data.Graph.Vertex , vertexToType ) where -import Prologue hiding (packageName) +import Prologue import Data.Aeson import qualified Data.Text as T import Data.Abstract.Module (ModuleInfo (..)) import Data.Abstract.Name -import Data.Abstract.Package (PackageInfo (..)) +import Data.Abstract.Package hiding (Package (Package)) -- | A vertex of some specific type. data Vertex @@ -23,7 +23,7 @@ data Vertex deriving (Eq, Ord, Show, Generic, Hashable) packageVertex :: PackageInfo -> Vertex -packageVertex = Package . formatName . packageName +packageVertex = Package . formatName . Data.Abstract.Package.packageName moduleVertex :: ModuleInfo -> Vertex moduleVertex = Module . T.pack . modulePath diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 1b2e4586e..58f6c21f0 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -1,5 +1,12 @@ {-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase #-} -module Data.Language where +module Data.Language + ( Language (..) + , ensureLanguage + , extensionsForLanguage + , knownLanguage + , languageForFilePath + , languageForType + ) where import Data.Aeson import Data.Char (toUpper) diff --git a/src/Data/Mergeable.hs b/src/Data/Mergeable.hs index d9b5c63fe..9dbcef29b 100644 --- a/src/Data/Mergeable.hs +++ b/src/Data/Mergeable.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DefaultSignatures, TypeOperators, UndecidableInstances #-} -module Data.Mergeable where +module Data.Mergeable ( Mergeable (..) ) where import Control.Applicative import Data.Functor.Identity diff --git a/src/Data/Options.hs b/src/Data/Options.hs deleted file mode 100644 index fe942341c..000000000 --- a/src/Data/Options.hs +++ /dev/null @@ -1 +0,0 @@ -module Data.Options where diff --git a/src/Data/Record.hs b/src/Data/Record.hs index 60902815f..761c2473c 100644 --- a/src/Data/Record.hs +++ b/src/Data/Record.hs @@ -1,5 +1,10 @@ {-# LANGUAGE ConstraintKinds, DataKinds, GADTs, KindSignatures, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Data.Record where +module Data.Record + ( Record (..) + , HasField (..) + , rhead + , rtail + ) where import Data.Aeson import Data.JSON.Fields diff --git a/src/Data/SplitDiff.hs b/src/Data/SplitDiff.hs index 3bf57d28f..0c040f3bd 100644 --- a/src/Data/SplitDiff.hs +++ b/src/Data/SplitDiff.hs @@ -1,4 +1,7 @@ -module Data.SplitDiff where +module Data.SplitDiff + ( SplitPatch (..) + , getRange + ) where import Control.Monad.Free import Data.Range @@ -20,6 +23,3 @@ getRange diff = getField $ case diff of -- | A diff with only one side’s annotations. type SplitDiff syntax ann = Free (TermF syntax ann) (SplitPatch (Term syntax ann)) - -unSplit :: Functor syntax => SplitDiff syntax ann -> Term syntax ann -unSplit = iter Term . fmap splitTerm diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index eef603e55..ac65c1498 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes, DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, KindSignatures, RankNTypes, ConstraintKinds, GeneralizedNewtypeDeriving, DerivingStrategies #-} -{-# OPTIONS_GHC -Wno-redundant-constraints -fno-warn-orphans #-} -- For HasCallStack +{-# OPTIONS_GHC -Wno-missing-export-lists -Wno-redundant-constraints -fno-warn-orphans #-} -- For HasCallStack module Data.Syntax where import Data.Abstract.Evaluatable diff --git a/src/Data/Syntax/Comment.hs b/src/Data/Syntax/Comment.hs index ce7854c59..3cddf53c6 100644 --- a/src/Data/Syntax/Comment.hs +++ b/src/Data/Syntax/Comment.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Comment where import Data.Abstract.Evaluatable diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 8d0b52b2a..d0c752015 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Declaration where import qualified Data.Abstract.Environment as Env diff --git a/src/Data/Syntax/Directive.hs b/src/Data/Syntax/Directive.hs index 9fe5df02a..fdee4066d 100644 --- a/src/Data/Syntax/Directive.hs +++ b/src/Data/Syntax/Directive.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Directive where import Data.Abstract.Evaluatable diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index aa042a0b4..d890debf0 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Expression where import Data.Abstract.Evaluatable hiding (Member) @@ -223,10 +224,7 @@ instance Ord1 Or where liftCompare = genericLiftCompare instance Show1 Or where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Or where - eval t = rvalBox =<< go (fmap subtermValue t) where - go (Or a b) = do - cond <- a - ifthenelse cond (pure cond) b + eval (Or a b) = disjunction (subtermValue a) (subtermValue b) >>= rvalBox data And a = And { lhs :: a, rhs :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 386d8c9cb..93a19a7ba 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, ViewPatterns, ScopedTypeVariables, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Literal where import Data.Abstract.Evaluatable diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 859a3a4d4..8813b79be 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, ScopedTypeVariables, UndecidableInstances, ViewPatterns, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Statement where import Data.Abstract.Evaluatable diff --git a/src/Data/Syntax/Type.hs b/src/Data/Syntax/Type.hs index fd1230229..882277e64 100644 --- a/src/Data/Syntax/Type.hs +++ b/src/Data/Syntax/Type.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Data.Syntax.Type where import Data.Abstract.Evaluatable diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index db0af7633..bf82e1d0c 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -1,5 +1,18 @@ {-# LANGUAGE DefaultSignatures, GADTs, TypeOperators, UndecidableInstances #-} -module Diffing.Algorithm where +module Diffing.Algorithm + ( AlgorithmF (..) + , Algorithm + , Diffable (..) + , Equivalence (..) + , diff + , diffThese + , diffMaybe + , linearly + , byReplacing + , comparableTerms + , equivalentTerms + , algorithmForTerms + ) where import Control.Monad.Free.Freer import Data.Diff diff --git a/src/Language/Go/Grammar.hs b/src/Language/Go/Grammar.hs index a82ed955c..685bbe253 100644 --- a/src/Language/Go/Grammar.hs +++ b/src/Language/Go/Grammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Go.Grammar where import Language.Haskell.TH diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index f5fddac5d..6b7e58bbe 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Go.Syntax where import Data.Abstract.Evaluatable diff --git a/src/Language/Go/Type.hs b/src/Language/Go/Type.hs index e035737fb..167d769e0 100644 --- a/src/Language/Go/Type.hs +++ b/src/Language/Go/Type.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Go.Type where import Prologue diff --git a/src/Language/Haskell/Grammar.hs b/src/Language/Haskell/Grammar.hs index 070d6bb3b..70074358b 100644 --- a/src/Language/Haskell/Grammar.hs +++ b/src/Language/Haskell/Grammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Haskell.Grammar where import Language.Haskell.TH diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index 50b78fb11..05d668d68 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Haskell.Syntax where import Data.Abstract.Evaluatable diff --git a/src/Language/JSON/Grammar.hs b/src/Language/JSON/Grammar.hs index 06b708cd3..17ee6f341 100644 --- a/src/Language/JSON/Grammar.hs +++ b/src/Language/JSON/Grammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.JSON.Grammar where import Language.Haskell.TH diff --git a/src/Language/Java/Grammar.hs b/src/Language/Java/Grammar.hs index 8d49da5e0..40eb06164 100644 --- a/src/Language/Java/Grammar.hs +++ b/src/Language/Java/Grammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Java.Grammar where import Language.Haskell.TH diff --git a/src/Language/Java/Syntax.hs b/src/Language/Java/Syntax.hs index 8ffac8839..655551fd7 100644 --- a/src/Language/Java/Syntax.hs +++ b/src/Language/Java/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Java.Syntax where import Data.Abstract.Evaluatable diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index ad0c76db7..bad66af9e 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Markdown.Syntax where import Prologue hiding (Text) diff --git a/src/Language/PHP/Grammar.hs b/src/Language/PHP/Grammar.hs index 9c01dbdbe..75bca0580 100644 --- a/src/Language/PHP/Grammar.hs +++ b/src/Language/PHP/Grammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.PHP.Grammar where import Language.Haskell.TH diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 37fa9e9d6..318a2f3a6 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.PHP.Syntax where import Control.Abstract.Modules diff --git a/src/Language/Python/Grammar.hs b/src/Language/Python/Grammar.hs index 6d22bc7bd..ed55fc12a 100644 --- a/src/Language/Python/Grammar.hs +++ b/src/Language/Python/Grammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Python.Grammar where import Language.Haskell.TH diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index ef7758b3f..315cdae0c 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Python.Syntax where import Data.Abstract.Environment as Env diff --git a/src/Language/Ruby/Grammar.hs b/src/Language/Ruby/Grammar.hs index df4a5d1e6..440c3e163 100644 --- a/src/Language/Ruby/Grammar.hs +++ b/src/Language/Ruby/Grammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Ruby.Grammar where import Language.Haskell.TH diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 81363850f..b78cc35f7 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, DuplicateRecordFields, TupleSections #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.Ruby.Syntax where import Control.Monad (unless) diff --git a/src/Language/TypeScript/Grammar.hs b/src/Language/TypeScript/Grammar.hs index 5a1224981..385fbaf79 100644 --- a/src/Language/TypeScript/Grammar.hs +++ b/src/Language/TypeScript/Grammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.TypeScript.Grammar where import Language.Haskell.TH diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index a803eb15d..cf151e094 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Language.TypeScript.Syntax where import qualified Data.Abstract.Environment as Env diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index 20d40566a..4c5333a15 100644 --- a/src/Semantic/AST.hs +++ b/src/Semantic/AST.hs @@ -1,5 +1,11 @@ {-# LANGUAGE GADTs, RankNTypes #-} -module Semantic.AST where +module Semantic.AST + ( SomeAST (..) + , withSomeAST + , astParseBlob + , ASTFormat (..) + , runASTParse + ) where import Data.AST import Data.Blob diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index a65c71c6b..704248dfe 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -1,6 +1,17 @@ {-# LANGUAGE LambdaCase #-} -module Semantic.Config where +module Semantic.Config + ( Config (..) + , defaultConfig + , Options (..) + , defaultOptions + , debugOptions + , lookupStatsAddr + , withHaystackFromConfig + , withLoggerFromConfig + , withStatterFromConfig + , withTelemetry + ) where import Network.BSD import Network.HTTP.Client.TLS diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 9e597f7bb..eb34fa5d6 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -1,5 +1,11 @@ {-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables #-} -module Semantic.Diff where +module Semantic.Diff + ( runDiff + , runRubyDiff + , runTypeScriptDiff + , runJSONDiff + , diffBlobTOCPairs + ) where import Analysis.ConstructorName (ConstructorName) import Analysis.Declaration (HasDeclaration, declarationAlgebra) diff --git a/src/Semantic/Env.hs b/src/Semantic/Env.hs index f01e88a8b..6dc30aa38 100644 --- a/src/Semantic/Env.hs +++ b/src/Semantic/Env.hs @@ -1,4 +1,7 @@ -module Semantic.Env where +module Semantic.Env + ( envLookupInt + , envLookupString + ) where import Control.Monad.IO.Class import Prologue diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 6ef49e711..f80849115 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -27,7 +27,6 @@ import Analysis.Abstract.Caching import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph import Control.Abstract -import Control.Monad.Effect (reinterpret) import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Module @@ -35,7 +34,7 @@ import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package as Package import Data.Abstract.Value.Abstract import Data.Abstract.Value.Type -import Data.Abstract.Value.Concrete (Value, ValueError (..), runValueErrorWith) +import Data.Abstract.Value.Concrete (Value,ValueError (..), runValueErrorWith) import Data.Graph import Data.Project import Data.Record @@ -90,9 +89,12 @@ runCallGraph :: ( HasField ann Span runCallGraph lang includePackages modules package = do let analyzeTerm = withTermSpans . graphingTerms . cachingTerms analyzeModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules - extractGraph (_, (_, (graph, _))) = simplify graph + extractGraph (graph, _) = simplify graph runGraphAnalysis - = runState (lowerBound @(Heap (Hole (Located Monovariant)) All Abstract)) + = runTermEvaluator @_ @(Hole (Maybe Name) (Located Monovariant)) @Abstract + . graphing + . caching + . runState (lowerBound @(Heap (Hole (Maybe Name) (Located Monovariant)) All Abstract)) . runFresh 0 . resumingLoadError . resumingUnspecialized @@ -100,13 +102,10 @@ runCallGraph lang includePackages modules package = do . resumingEvalError . resumingResolutionError . resumingAddressError - . runTermEvaluator @_ @(Hole (Located Monovariant)) @Abstract - . graphing - . caching @[] . runReader (packageInfo package) . runReader (lowerBound @Span) . providingLiveSet - . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Located Monovariant))))))) + . runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult (Hole (Maybe Name) (Located Monovariant))))))) . raiseHandler (runModules (ModuleTable.modulePaths (packageModules package))) extractGraph <$> runEvaluator (runGraphAnalysis (evaluate lang analyzeModule analyzeTerm modules)) @@ -130,7 +129,7 @@ runImportGraph lang (package :: Package term) | [m :| []] <- toList (packageModules package) = vertex m <$ trace ("single module, skipping import graph computation for " <> modulePath (moduleInfo m)) | otherwise = let analyzeModule = graphingModuleInfo - extractGraph (_, (_, (graph, _))) = do + extractGraph (_, (graph, _)) = do info <- graph maybe lowerBound (foldMap vertex) (ModuleTable.lookup (modulePath info) (packageModules package)) runImportGraphAnalysis @@ -146,7 +145,7 @@ runImportGraph lang (package :: Package term) . runState lowerBound . runReader lowerBound . runModules (ModuleTable.modulePaths (packageModules package)) - . runTermEvaluator @_ @_ @(Value (Hole Precise) (ImportGraphEff term (Hole Precise) effs)) + . runTermEvaluator @_ @_ @(Value (Hole (Maybe Name) Precise) (ImportGraphEff term (Hole (Maybe Name) Precise) effs)) . runReader (packageInfo package) . runReader lowerBound in extractGraph <$> runEvaluator (runImportGraphAnalysis (evaluate @_ @_ @_ @_ @term lang analyzeModule id (ModuleTable.toPairs (packageModules package) >>= toList . snd))) @@ -215,10 +214,10 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr NotFoundError nameToResolve _ _ -> pure nameToResolve GoImportError pathToResolve -> pure [pathToResolve]) -resumingLoadError :: (Member Trace effects, AbstractHole address, Effects effects) => Evaluator address value (Resumable (LoadError address) ': effects) a -> Evaluator address value effects a +resumingLoadError :: (AbstractHole address, Effectful (m address value), Effects effects, Functor (m address value effects), Member Trace effects) => m address value (Resumable (LoadError address) ': effects) a -> m address value effects a resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> (lowerBound, hole)) -resumingEvalError :: (Member Fresh effects, Member Trace effects, Effects effects) => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a +resumingEvalError :: (Applicative (m effects), Effectful m, Effects effects, Member Fresh effects, Member Trace effects) => m (Resumable EvalError ': effects) a -> m effects a resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError:" <> prettyShow err) *> case err of DefaultExportError{} -> pure () ExportError{} -> pure () @@ -227,15 +226,15 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError:" <> prettyShow RationalFormatError{} -> pure 0 NoNameError -> gensym) -resumingUnspecialized :: (Member Trace effects, AbstractHole value, Effects effects) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a +resumingUnspecialized :: (AbstractHole value, Effectful (m value), Effects effects, Functor (m value effects), Member Trace effects) => m value (Resumable (Unspecialized value) ': effects) a -> m value effects a resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized: " <> prettyShow err) $> hole) -resumingAddressError :: (AbstractHole value, Lower (Cell address value), Member Trace effects, Show address, Effects effects) => Evaluator address value (Resumable (AddressError address value) ': effects) a -> Evaluator address value effects a -resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError: " <> prettyShow err) *> case err of - UnallocatedAddress _ -> pure lowerBound - UninitializedAddress _ -> pure hole) +resumingAddressError :: (AbstractHole value, Applicative (m address value effects), Effectful (m address value), Effects effects, Lower (Cell address value), Member Trace effects, Show address) => m address value (Resumable (AddressError address value) ': effects) a -> m address value effects a +resumingAddressError = runAddressErrorWith $ \ err -> trace ("AddressError: " <> prettyShow err) *> case err of + UnallocatedAddress _ -> pure lowerBound + UninitializedAddress _ -> pure hole -resumingValueError :: (Member Trace effects, Show address, Effects effects) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a +resumingValueError :: (Applicative (m address (Value address body) effects), Effectful (m address (Value address body)), Effects effects, Member Trace effects, Show address) => m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects a resumingValueError = runValueErrorWith (\ err -> trace ("ValueError: " <> prettyShow err) *> case err of CallError val -> pure val StringError val -> pure (pack (prettyShow val)) @@ -251,10 +250,8 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError: " <> pretty KeyValueError{} -> pure (hole, hole) ArithmeticError{} -> pure hole) -resumingEnvironmentError :: (AbstractHole address, Effects effects) => Evaluator address value (Resumable (EnvironmentError address) ': effects) a -> Evaluator address value effects ([Name], a) -resumingEnvironmentError - = runState [] - . reinterpret (\ (Resumable (FreeVariable name)) -> modify' (name :) $> hole) +resumingEnvironmentError :: (Applicative (m (Hole (Maybe Name) address) value effects), Effectful (m (Hole (Maybe Name) address) value), Effects effects) => m (Hole (Maybe Name) address) value (Resumable (EnvironmentError (Hole (Maybe Name) address)) ': effects) a -> m (Hole (Maybe Name) address) value effects a +resumingEnvironmentError = runResumableWith (\ (FreeVariable name) -> pure (Partial (Just name))) resumingTypeError :: ( Alternative (m address Type (State TypeMap ': effects)) , Effects effects diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index d8e2791ec..bb0184c40 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -1,5 +1,10 @@ {-# LANGUAGE GADTs, RankNTypes #-} -module Semantic.Parse where +module Semantic.Parse + ( runParse + , runRubyParse + , runTypeScriptParse + , runJSONParse + ) where import Analysis.ConstructorName (ConstructorName) import Analysis.Declaration (HasDeclaration, declarationAlgebra) diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 62ed86246..a014ce2d9 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -1,5 +1,10 @@ {-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} -module Semantic.Resolution where +module Semantic.Resolution + ( Resolution (..) + , nodeJSResolutionMap + , resolutionMap + , runResolution + ) where import Control.Monad.Effect import Data.Aeson diff --git a/src/Semantic/Telemetry/Haystack.hs b/src/Semantic/Telemetry/Haystack.hs index 86706f636..463eed18e 100644 --- a/src/Semantic/Telemetry/Haystack.hs +++ b/src/Semantic/Telemetry/Haystack.hs @@ -1,4 +1,10 @@ -module Semantic.Telemetry.Haystack where +module Semantic.Telemetry.Haystack + ( HaystackClient (..) + , ErrorReport (..) + , ErrorLogger + , haystackClient + , reportError + ) where import Control.Exception import Crypto.Hash diff --git a/src/Semantic/Telemetry/Log.hs b/src/Semantic/Telemetry/Log.hs index 8a116e017..ce826266d 100644 --- a/src/Semantic/Telemetry/Log.hs +++ b/src/Semantic/Telemetry/Log.hs @@ -1,4 +1,12 @@ -module Semantic.Telemetry.Log where +module Semantic.Telemetry.Log + ( Level (..) + , LogOptions (..) + , Message (..) + , LogFormatter + , logfmtFormatter + , terminalFormatter + , writeLogMessage + ) where import Control.Monad.IO.Class import Data.Error (withSGRCode) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 299be109f..2d7f4d612 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists #-} module Semantic.Util where import Prelude hiding (readFile) @@ -83,7 +83,7 @@ checking . runFresh 0 . runPrintingTrace . runTermEvaluator @_ @Monovariant @Type - . caching @[] + . caching . providingLiveSet . fmap reassociate . runLoadError @@ -108,7 +108,7 @@ callGraphProject parser proxy lang opts paths = runTaskWithOptions opts $ do package <- parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang []) modules <- topologicalSort <$> runImportGraph proxy package x <- runCallGraph proxy False modules package - pure (x, modules) + pure (x, (() <$) <$> modules) callGraphRubyProject = callGraphProject rubyParser (Proxy @'Language.Ruby) Language.Ruby debugOptions diff --git a/src/Semantic/Version.hs b/src/Semantic/Version.hs index 0a836d905..782cbc1f8 100644 --- a/src/Semantic/Version.hs +++ b/src/Semantic/Version.hs @@ -1,6 +1,9 @@ {-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct. {-# LANGUAGE TemplateHaskell #-} -module Semantic.Version where +module Semantic.Version + ( buildSHA + , buildVersion + ) where import Data.Version (showVersion) import Development.GitRev