From dad7be04af91baff029690fd80de2a6c1a34e0a0 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 27 Feb 2019 14:20:36 -0500 Subject: [PATCH 01/32] First results from `bribe` upgrades. --- .licenses/semantic/cabal/haskeline.txt | 2 +- .licenses/semantic/cabal/recursion-schemes.txt | 2 +- .licenses/semantic/cabal/semigroupoids.txt | 2 +- .licenses/semantic/cabal/these.txt | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.licenses/semantic/cabal/haskeline.txt b/.licenses/semantic/cabal/haskeline.txt index c65bc1c34..914d24ffd 100644 --- a/.licenses/semantic/cabal/haskeline.txt +++ b/.licenses/semantic/cabal/haskeline.txt @@ -1,7 +1,7 @@ --- type: cabal name: haskeline -version: 0.7.4.3 +version: 0.7.5.0 summary: A command-line interface for user input, written in Haskell. homepage: https://github.com/judah/haskeline license: bsd-2-clause diff --git a/.licenses/semantic/cabal/recursion-schemes.txt b/.licenses/semantic/cabal/recursion-schemes.txt index 799fa08d6..662bb4153 100644 --- a/.licenses/semantic/cabal/recursion-schemes.txt +++ b/.licenses/semantic/cabal/recursion-schemes.txt @@ -1,7 +1,7 @@ --- type: cabal name: recursion-schemes -version: '5.1' +version: 5.1.1 summary: Generalized bananas, lenses and barbed wire homepage: https://github.com/ekmett/recursion-schemes/ license: bsd-2-clause diff --git a/.licenses/semantic/cabal/semigroupoids.txt b/.licenses/semantic/cabal/semigroupoids.txt index c550918c8..4f22fc668 100644 --- a/.licenses/semantic/cabal/semigroupoids.txt +++ b/.licenses/semantic/cabal/semigroupoids.txt @@ -1,7 +1,7 @@ --- type: cabal name: semigroupoids -version: 5.3.1 +version: 5.3.2 summary: 'Semigroupoids: Category sans id' homepage: https://github.com/ekmett/semigroupoids license: bsd-2-clause diff --git a/.licenses/semantic/cabal/these.txt b/.licenses/semantic/cabal/these.txt index 07e4c71c7..02b84c647 100644 --- a/.licenses/semantic/cabal/these.txt +++ b/.licenses/semantic/cabal/these.txt @@ -1,7 +1,7 @@ --- type: cabal name: these -version: 0.7.5 +version: 0.7.6 summary: An either-or-both data type & a generalized 'zip with padding' typeclass homepage: https://github.com/isomorphism/these license: bsd-3-clause From fd76bfe42fe1b1b6ee0cc415abddae178ae23218 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 27 Feb 2019 15:34:47 -0500 Subject: [PATCH 02/32] After removing --depth=1. --- .licenses/semantic/cabal/basement.txt | 2 +- .licenses/semantic/cabal/cereal.txt | 2 +- .licenses/semantic/cabal/parser-combinators.txt | 2 +- .licenses/semantic/cabal/swagger2.txt | 2 +- .licenses/semantic/cabal/vector-builder.txt | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/.licenses/semantic/cabal/basement.txt b/.licenses/semantic/cabal/basement.txt index b17738cac..7533d24f5 100644 --- a/.licenses/semantic/cabal/basement.txt +++ b/.licenses/semantic/cabal/basement.txt @@ -1,7 +1,7 @@ --- type: cabal name: basement -version: 0.0.8 +version: 0.0.10 summary: Foundation scrap box of array & string homepage: https://github.com/haskell-foundation/foundation license: bsd-3-clause diff --git a/.licenses/semantic/cabal/cereal.txt b/.licenses/semantic/cabal/cereal.txt index fabadd6f6..e67a054a6 100644 --- a/.licenses/semantic/cabal/cereal.txt +++ b/.licenses/semantic/cabal/cereal.txt @@ -1,7 +1,7 @@ --- type: cabal name: cereal -version: 0.5.7.0 +version: 0.5.8.0 summary: A binary serialization library homepage: https://github.com/GaloisInc/cereal license: bsd-3-clause diff --git a/.licenses/semantic/cabal/parser-combinators.txt b/.licenses/semantic/cabal/parser-combinators.txt index 37130ecef..1094f53b6 100644 --- a/.licenses/semantic/cabal/parser-combinators.txt +++ b/.licenses/semantic/cabal/parser-combinators.txt @@ -1,7 +1,7 @@ --- type: cabal name: parser-combinators -version: 1.0.0 +version: 1.0.1 summary: Lightweight package providing commonly useful parser combinators homepage: https://github.com/mrkkrp/parser-combinators license: bsd-3-clause diff --git a/.licenses/semantic/cabal/swagger2.txt b/.licenses/semantic/cabal/swagger2.txt index f8a417c88..7213a77c8 100644 --- a/.licenses/semantic/cabal/swagger2.txt +++ b/.licenses/semantic/cabal/swagger2.txt @@ -1,7 +1,7 @@ --- type: cabal name: swagger2 -version: 2.3.1 +version: 2.3.1.1 summary: Swagger 2.0 data model homepage: https://github.com/GetShopTV/swagger2 license: bsd-3-clause diff --git a/.licenses/semantic/cabal/vector-builder.txt b/.licenses/semantic/cabal/vector-builder.txt index 1e6cd9787..87f29ec88 100644 --- a/.licenses/semantic/cabal/vector-builder.txt +++ b/.licenses/semantic/cabal/vector-builder.txt @@ -1,7 +1,7 @@ --- type: cabal name: vector-builder -version: 0.3.6 +version: 0.3.7.2 summary: Vector builder homepage: https://github.com/nikita-volkov/vector-builder license: mit From aa197eb107fa5562ff743142c6a5f4304596c211 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 27 Feb 2019 16:18:42 -0500 Subject: [PATCH 03/32] Something in that last revision made licensed segfault. --- .licenses/semantic/cabal/semigroupoids.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.licenses/semantic/cabal/semigroupoids.txt b/.licenses/semantic/cabal/semigroupoids.txt index 4f22fc668..6d48a2e02 100644 --- a/.licenses/semantic/cabal/semigroupoids.txt +++ b/.licenses/semantic/cabal/semigroupoids.txt @@ -2,7 +2,7 @@ type: cabal name: semigroupoids version: 5.3.2 -summary: 'Semigroupoids: Category sans id' +summary: Semigroupoids: Category sans id homepage: https://github.com/ekmett/semigroupoids license: bsd-2-clause --- From 2eb1280681ea695cd02aa7ac9514c93748fd469f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 14:01:27 -0500 Subject: [PATCH 04/32] WIP --- src/Rendering/Graph.hs | 5 +- src/Semantic/Api/Helpers.hs | 141 ++++++++++++++++++++---------------- 2 files changed, 80 insertions(+), 66 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index f30a72db5..dbd9b3fcc 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -20,6 +20,7 @@ import Data.Term import Prologue import Semantic.Api.Helpers import Semantic.Api.V1.CodeAnalysisPB +import Control.Lens import qualified Data.Text as T @@ -72,7 +73,7 @@ instance (ConstructorName syntax, Foldable syntax) => termAlgebra (In ann syntax) = do i <- fresh parent <- ask - let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (spanToSpan (locationSpan ann))) + let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (locationSpan ann ^? bridging)) subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax pure (parent `connect` root `overlay` subGraph) @@ -91,7 +92,7 @@ instance (ConstructorName syntax, Foldable syntax) => graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan)))) pure (parent `connect` replace `overlay` graph) where - ann a = spanToSpan (locationSpan a) + ann a = a ^? to locationSpan.bridging diffAlgebra :: ( Foldable f , Member Fresh sig diff --git a/src/Semantic/Api/Helpers.hs b/src/Semantic/Api/Helpers.hs index edf619a29..d7420a7b5 100644 --- a/src/Semantic/Api/Helpers.hs +++ b/src/Semantic/Api/Helpers.hs @@ -1,39 +1,94 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FunctionalDependencies, LambdaCase, MultiParamTypeClasses #-} module Semantic.Api.Helpers - ( spanToSpan - , spanToLegacySpan + ( APIBridge (..) , toChangeType - , languageToApiLanguage - , apiSpanToSpan - , apiLanguageToLanguage , apiBlobsToBlobs - , apiBlobToBlob - , apiBlobPairsToBlobPairs - , apiBlobPairToBlobPair ) where +import Prologue + +import Control.Lens import qualified Data.Blob as Data import qualified Data.Language as Data -import Data.Source (fromText) +import Data.Source (fromText, toText) import qualified Data.Span as Data import qualified Data.Text as T import qualified Data.Vector as V import qualified Semantic.Api.LegacyTypes as Legacy import qualified Semantic.Api.V1.CodeAnalysisPB as API -spanToSpan :: Data.Span -> Maybe API.Span -spanToSpan Data.Span{..} = Just $ API.Span (toPos spanStart) (toPos spanEnd) - where toPos Data.Pos{..} = Just $ API.Position (fromIntegral posLine) (fromIntegral posColumn) +class APIConvert api native | api -> native where + converting :: Prism' api native -spanToLegacySpan :: Data.Span -> Maybe Legacy.Span -spanToLegacySpan Data.Span{..} = Just $ Legacy.Span (toPos spanStart) (toPos spanEnd) - where toPos Data.Pos{..} = Just $ Legacy.Position posLine posColumn +class APIBridge api native | api -> native where + bridging :: Iso' api native -apiSpanToSpan :: Maybe API.Span -> Data.Span -apiSpanToSpan (Just API.Span{..}) = Data.Span (toPos start) (toPos end) - where toPos (Just API.Position{..}) = Data.Pos (fromIntegral line) (fromIntegral column) - toPos Nothing = Data.Pos 1 1 -apiSpanToSpan Nothing = Data.emptySpan +instance APIBridge Legacy.Position Data.Pos where + bridging = iso fromAPI toAPI where + toAPI Data.Pos{..} = Legacy.Position posLine posColumn + fromAPI Legacy.Position{..} = Data.Pos line column + +instance APIBridge API.Position Data.Pos where + bridging = iso fromAPI toAPI where + toAPI Data.Pos{..} = API.Position (fromIntegral posLine) (fromIntegral posColumn) + fromAPI API.Position{..} = Data.Pos (fromIntegral line) (fromIntegral column) + +instance APIBridge Data.Span API.Span where + bridging = iso toAPI fromAPI where + toAPI Data.Span{..} = API.Span (spanStart ^? re bridging) (spanEnd ^? re bridging) + fromAPI API.Span{..} = Data.Span (start^.non single.bridging) (end^.non single.bridging) + single = API.Position 1 1 + +instance APIBridge API.Language Data.Language where + bridging = iso apiLanguageToLanguage languageToApiLanguage where + languageToApiLanguage :: Data.Language -> API.Language + languageToApiLanguage = \case + Data.Unknown -> API.Unknown + Data.Go -> API.Go + Data.Haskell -> API.Haskell + Data.Java -> API.Java + Data.JavaScript -> API.Javascript + Data.JSON -> API.Json + Data.JSX -> API.Jsx + Data.Markdown -> API.Markdown + Data.Python -> API.Python + Data.Ruby -> API.Ruby + Data.TypeScript -> API.Typescript + Data.PHP -> API.Php + + apiLanguageToLanguage :: API.Language -> Data.Language + apiLanguageToLanguage = \case + API.Unknown -> Data.Unknown + API.Go -> Data.Go + API.Haskell -> Data.Haskell + API.Java -> Data.Java + API.Javascript -> Data.JavaScript + API.Json -> Data.JSON + API.Jsx -> Data.JSX + API.Markdown -> Data.Markdown + API.Python -> Data.Python + API.Ruby -> Data.Ruby + API.Typescript -> Data.TypeScript + API.Php -> Data.PHP + +instance APIBridge API.Blob Data.Blob where + bridging = iso apiBlobToBlob blobToApiBlob where + blobToApiBlob Data.Blob{..} = API.Blob (toText blobSource) (T.pack blobPath) (bridging # blobLanguage) + apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (language ^. bridging) + + +instance APIConvert API.BlobPair Data.BlobPair where + converting = prism' blobPairToApiBlobPair apiBlobPairToBlobPair where + + apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Just $ Data.Diffing (before^.bridging) (after^.bridging) + apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Just $ Data.Deleting (before^.bridging) + apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Just $ Data.Inserting (after^.bridging) + apiBlobPairToBlobPair _ = Nothing + + + blobPairToApiBlobPair (Data.Diffing before after) = API.BlobPair (before ^? re bridging) (after ^? re bridging) + blobPairToApiBlobPair (Data.Inserting after) = API.BlobPair Nothing (after ^? re bridging) + blobPairToApiBlobPair (Data.Deleting before) = API.BlobPair (before ^? re bridging) Nothing toChangeType :: T.Text -> API.ChangeType toChangeType = \case @@ -42,47 +97,5 @@ toChangeType = \case "removed" -> API.Removed _ -> API.None -languageToApiLanguage :: Data.Language -> API.Language -languageToApiLanguage = \case - Data.Unknown -> API.Unknown - Data.Go -> API.Go - Data.Haskell -> API.Haskell - Data.Java -> API.Java - Data.JavaScript -> API.Javascript - Data.JSON -> API.Json - Data.JSX -> API.Jsx - Data.Markdown -> API.Markdown - Data.Python -> API.Python - Data.Ruby -> API.Ruby - Data.TypeScript -> API.Typescript - Data.PHP -> API.Php - -apiLanguageToLanguage :: API.Language -> Data.Language -apiLanguageToLanguage = \case - API.Unknown -> Data.Unknown - API.Go -> Data.Go - API.Haskell -> Data.Haskell - API.Java -> Data.Java - API.Javascript -> Data.JavaScript - API.Json -> Data.JSON - API.Jsx -> Data.JSX - API.Markdown -> Data.Markdown - API.Python -> Data.Python - API.Ruby -> Data.Ruby - API.Typescript -> Data.TypeScript - API.Php -> Data.PHP - apiBlobsToBlobs :: V.Vector API.Blob -> [Data.Blob] -apiBlobsToBlobs = V.toList . fmap apiBlobToBlob - -apiBlobToBlob :: API.Blob -> Data.Blob -apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (apiLanguageToLanguage language) - -apiBlobPairsToBlobPairs :: V.Vector API.BlobPair -> [Data.BlobPair] -apiBlobPairsToBlobPairs = V.toList . fmap apiBlobPairToBlobPair - -apiBlobPairToBlobPair :: API.BlobPair -> Data.BlobPair -apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Data.Diffing (apiBlobToBlob before) (apiBlobToBlob after) -apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Data.Deleting (apiBlobToBlob before) -apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Data.Inserting (apiBlobToBlob after) -apiBlobPairToBlobPair _ = Prelude.error "Expected BlobPair to have either 'before' and/or 'after'." +apiBlobsToBlobs = V.toList . fmap (^.bridging) From 7204da395166ea3f0bd4a05997cd2ee41ce2221f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 14:17:23 -0500 Subject: [PATCH 05/32] RFC: unified interface for converting API/legacy/native types. As we've brought up a Twirp-based API, we've found a need to convert between several different "views" of the same data, such as position or span information. Because all protobuf fields are optional, we have to juggle the `Maybe` values associated with the protobuf fields that we are converting. While I think this approach has merit, there is a complexity overhead associated with these conversions: we currently have around ten ad-hoc functions that perform these conversions, often containing superfluous `Maybe`s for the sake of convenience. I've replaced these ad-hoc functions with two classes: `APIBridge` and `APIConvert`. An instance of `APIBridge` between types `a` and `b` means that we can convert between `a` and `b` and vice versa losslessly; in other words, there is an isomorphism between them. `APIConvert` means that you can convert from an `a` to a `b`, but you may not be able to convert from all `b`s to an `a` (such as in the case of missing fields); in other words, there is a partial isomorphism. These are implemented with concepts from `lens`, namely an `Iso` for `APIBridge` and a `Prism` for `APIConvert`. Advantages of this approach: * Lawful API. We can now clearly delineate the fact that converting a native data type to an API data type always succeeds, but the reverse may fail: an API `Span` may have missing position information, and we want to handle that explicitly, rather than paper over it with these helper functions. Both the APIBridge and APIConvert typeclasses provide a set of strong laws re. behavior, since they provide a lens-y interface. * Unified API. No longer do we have to juggle a set of functions in our heads - no need to choose between `spanToSpan`, `spanToLegacySpan`, or `apiSpanToSpan`. `converting` and `bridging` do the work for you. Everything is much cleaner. * Fewer partial functions. The converter from API blob pairs to native blob pairs no longer calls `error`, which is definitely a good thing. * Historical precedent. Prisms and isomorphisms are a fluent way to express data transformations; the team behind Minecraft uses isomorphisms and prisms [to transfer data between versions][minecraft]. Disadvantages: * Complexity overhead. You have to learn about prisms, reviews, isomorphisms, neither of which is the world's hardest concept but which take a little while to internalize. * This might be polymorphism for polymorphism's sake. Something we could do is postpone this patch until I have a chance to give a lens tutorial in a Codex. [minecraft]: https://github.com/Mojang/DataFixerUpper --- src/Rendering/Graph.hs | 4 ++-- src/Semantic/Api/Diffs.hs | 3 ++- src/Semantic/Api/Helpers.hs | 25 ++++++++----------------- src/Semantic/Api/Symbols.hs | 9 +++++---- src/Semantic/Api/TOCSummaries.hs | 17 ++++++++++++----- src/Semantic/Api/Terms.hs | 3 ++- 6 files changed, 31 insertions(+), 30 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index dbd9b3fcc..667e32c66 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -73,7 +73,7 @@ instance (ConstructorName syntax, Foldable syntax) => termAlgebra (In ann syntax) = do i <- fresh parent <- ask - let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (locationSpan ann ^? bridging)) + let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (locationSpan ann ^? re bridging)) subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax pure (parent `connect` root `overlay` subGraph) @@ -92,7 +92,7 @@ instance (ConstructorName syntax, Foldable syntax) => graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan)))) pure (parent `connect` replace `overlay` graph) where - ann a = a ^? to locationSpan.bridging + ann a = a ^? to locationSpan . re bridging diffAlgebra :: ( Foldable f , Member Fresh sig diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index d42e8e50b..e7a8c135c 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -16,6 +16,7 @@ import Analysis.TOCSummary (HasDeclaration) import Control.Effect import Control.Effect.Error import Control.Exception +import Control.Lens import Control.Monad.IO.Class import Data.Blob import Data.ByteString.Builder @@ -75,7 +76,7 @@ diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))])) where path = T.pack $ pathForBlobPair blobPair - lang = languageToApiLanguage $ languageForBlobPair blobPair + lang = bridging # languageForBlobPair blobPair render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Location Location -> m DiffTreeFileGraph render _ diff = diff --git a/src/Semantic/Api/Helpers.hs b/src/Semantic/Api/Helpers.hs index d7420a7b5..0d7786b42 100644 --- a/src/Semantic/Api/Helpers.hs +++ b/src/Semantic/Api/Helpers.hs @@ -1,19 +1,15 @@ {-# LANGUAGE FunctionalDependencies, LambdaCase, MultiParamTypeClasses #-} module Semantic.Api.Helpers ( APIBridge (..) - , toChangeType - , apiBlobsToBlobs + , APIConvert (..) ) where -import Prologue - import Control.Lens import qualified Data.Blob as Data import qualified Data.Language as Data import Data.Source (fromText, toText) import qualified Data.Span as Data import qualified Data.Text as T -import qualified Data.Vector as V import qualified Semantic.Api.LegacyTypes as Legacy import qualified Semantic.Api.V1.CodeAnalysisPB as API @@ -33,12 +29,17 @@ instance APIBridge API.Position Data.Pos where toAPI Data.Pos{..} = API.Position (fromIntegral posLine) (fromIntegral posColumn) fromAPI API.Position{..} = Data.Pos (fromIntegral line) (fromIntegral column) -instance APIBridge Data.Span API.Span where - bridging = iso toAPI fromAPI where +instance APIBridge API.Span Data.Span where + bridging = iso fromAPI toAPI where toAPI Data.Span{..} = API.Span (spanStart ^? re bridging) (spanEnd ^? re bridging) fromAPI API.Span{..} = Data.Span (start^.non single.bridging) (end^.non single.bridging) single = API.Position 1 1 +instance APIConvert Legacy.Span Data.Span where + converting = prism' dataToLegacy legacyToData where + dataToLegacy Data.Span{..} = Legacy.Span (spanStart ^? re bridging) (spanEnd ^? re bridging) + legacyToData Legacy.Span {..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging) + instance APIBridge API.Language Data.Language where bridging = iso apiLanguageToLanguage languageToApiLanguage where languageToApiLanguage :: Data.Language -> API.Language @@ -89,13 +90,3 @@ instance APIConvert API.BlobPair Data.BlobPair where blobPairToApiBlobPair (Data.Diffing before after) = API.BlobPair (before ^? re bridging) (after ^? re bridging) blobPairToApiBlobPair (Data.Inserting after) = API.BlobPair Nothing (after ^? re bridging) blobPairToApiBlobPair (Data.Deleting before) = API.BlobPair (before ^? re bridging) Nothing - -toChangeType :: T.Text -> API.ChangeType -toChangeType = \case - "added" -> API.Added - "modified" -> API.Modified - "removed" -> API.Removed - _ -> API.None - -apiBlobsToBlobs :: V.Vector API.Blob -> [Data.Blob] -apiBlobsToBlobs = V.toList . fmap (^.bridging) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index a78d34bf9..02fdfc156 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -10,6 +10,7 @@ import Prelude hiding (span) import Control.Effect import Control.Effect.Error import Control.Exception +import Control.Lens import Data.Blob import Data.ByteString.Builder import Data.Location @@ -48,7 +49,7 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap { symbolName = name , symbolKind = kind , symbolLine = fromMaybe mempty line - , symbolSpan = spanToLegacySpan span + , symbolSpan = span ^? re converting } parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Builder @@ -60,13 +61,13 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Blob -> m File go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException e) -> pure $ errorFile (show e)) where - errorFile e = File (pack blobPath) (languageToApiLanguage blobLanguage) mempty (V.fromList [ParseError (T.pack e)]) + errorFile e = File (pack blobPath) (bridging # blobLanguage) mempty (V.fromList [ParseError (T.pack e)]) renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m File renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob term) tagsToFile :: Blob -> [Tag] -> File - tagsToFile Blob{..} tags = File (pack blobPath) (languageToApiLanguage blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty + tagsToFile Blob{..} tags = File (pack blobPath) (bridging # blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty tagToSymbol :: Tag -> Symbol tagToSymbol Tag{..} @@ -74,6 +75,6 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut { symbol = name , kind = kind , line = fromMaybe mempty line - , span = spanToSpan span + , span = span ^? re bridging , docs = fmap Docstring docs } diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 2a3ba6504..3f36afcdf 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies #-} +{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies, LambdaCase #-} module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where import Analysis.TOCSummary (Declaration, declarationAlgebra) import Control.Effect.Error +import Control.Lens import Data.Aeson import Data.Blob import Data.ByteString.Builder @@ -42,16 +43,22 @@ diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor blobs go `catchError` \(SomeException e) -> pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing]) where path = T.pack $ pathKeyForBlobPair blobPair - lang = languageToApiLanguage $ languageForBlobPair blobPair + lang = bridging # languageForBlobPair blobPair render :: (Foldable syntax, Functor syntax, Applicative m) => BlobPair -> Diff syntax (Maybe Declaration) (Maybe Declaration) -> m TOCSummaryFile render blobPair diff = pure $ foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff) where path = T.pack $ pathKeyForBlobPair blobPair - lang = languageToApiLanguage $ languageForBlobPair blobPair + lang = bridging # languageForBlobPair blobPair + + toChangeType = \case + "added" -> Added + "modified" -> Modified + "removed" -> Removed + _ -> None go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile go TOCSummary{..} TOCSummaryFile{..} - = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (spanToSpan summarySpan) (toChangeType summaryChangeType)) changes) errors + = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (summarySpan ^? re bridging) (toChangeType summaryChangeType)) changes) errors go ErrorSummary{..} TOCSummaryFile{..} - = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (spanToSpan errorSpan)) errors) + = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (errorSpan ^? re bridging)) errors) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 9bf5ad7a3..887a3e946 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -17,6 +17,7 @@ module Semantic.Api.Terms import Analysis.ConstructorName (ConstructorName) import Control.Effect import Control.Effect.Error +import Control.Lens import Control.Monad import Control.Monad.IO.Class import Data.Abstract.Declarations @@ -52,7 +53,7 @@ termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor pure (ParseTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))])) where path = T.pack $ blobPath blob - lang = languageToApiLanguage $ blobLanguage blob + lang = bridging # blobLanguage blob render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Location -> ParseTreeFileGraph render t = let graph = renderTreeGraph t From b92d9a5382af9a973f11e14cc40de4c63285b97e Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 15:27:13 -0500 Subject: [PATCH 06/32] Rename Helpers to Bridge. --- semantic.cabal | 2 +- src/Rendering/Graph.hs | 2 +- src/Semantic/Api/{Helpers.hs => Bridge.hs} | 2 +- src/Semantic/Api/Diffs.hs | 2 +- src/Semantic/Api/Symbols.hs | 2 +- src/Semantic/Api/TOCSummaries.hs | 2 +- src/Semantic/Api/Terms.hs | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) rename src/Semantic/Api/{Helpers.hs => Bridge.hs} (99%) diff --git a/semantic.cabal b/semantic.cabal index 973234396..45e6cf5df 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -239,7 +239,7 @@ library -- API , Semantic.Api , Semantic.Api.Diffs - , Semantic.Api.Helpers + , Semantic.Api.Bridge , Semantic.Api.LegacyTypes , Semantic.Api.Symbols , Semantic.Api.Terms diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 667e32c66..98d8e7895 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -18,7 +18,7 @@ import Data.Patch import Data.String (IsString (..)) import Data.Term import Prologue -import Semantic.Api.Helpers +import Semantic.Api.Bridge import Semantic.Api.V1.CodeAnalysisPB import Control.Lens diff --git a/src/Semantic/Api/Helpers.hs b/src/Semantic/Api/Bridge.hs similarity index 99% rename from src/Semantic/Api/Helpers.hs rename to src/Semantic/Api/Bridge.hs index 0d7786b42..9706b763c 100644 --- a/src/Semantic/Api/Helpers.hs +++ b/src/Semantic/Api/Bridge.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FunctionalDependencies, LambdaCase, MultiParamTypeClasses #-} -module Semantic.Api.Helpers +module Semantic.Api.Bridge ( APIBridge (..) , APIConvert (..) ) where diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index e7a8c135c..5fd41f9dc 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -34,7 +34,7 @@ import Prologue import Rendering.Graph import Rendering.JSON hiding (JSON) import qualified Rendering.JSON -import Semantic.Api.Helpers +import Semantic.Api.Bridge import Semantic.Api.V1.CodeAnalysisPB hiding (Blob, BlobPair, Language(..)) import Semantic.Task as Task import Semantic.Telemetry as Stat diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 02fdfc156..d563f233a 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -21,7 +21,7 @@ import qualified Data.Vector as V import Data.Text (pack) import Parsing.Parser import Prologue -import Semantic.Api.Helpers +import Semantic.Api.Bridge import qualified Semantic.Api.LegacyTypes as Legacy import Semantic.Api.Terms (ParseEffects, doParse) import Semantic.Api.V1.CodeAnalysisPB hiding (Blob) diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 3f36afcdf..e3b1689f6 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -14,7 +14,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import Rendering.TOC import Semantic.Api.Diffs -import Semantic.Api.Helpers +import Semantic.Api.Bridge import Semantic.Api.V1.CodeAnalysisPB hiding (Blob, BlobPair) import Semantic.Task as Task import Serializing.Format diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 887a3e946..43564e8d3 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -37,7 +37,7 @@ import Prologue import Rendering.Graph import Rendering.JSON hiding (JSON) import qualified Rendering.JSON -import Semantic.Api.Helpers +import Semantic.Api.Bridge import Semantic.Api.V1.CodeAnalysisPB hiding (Blob, Language (..)) import Semantic.Task import Serializing.Format hiding (JSON) From 83322e9f94cfc92d8f61716771ae7a7f02f661e9 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 15:28:22 -0500 Subject: [PATCH 07/32] Fix lints. --- src/Semantic/Api/Bridge.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index 9706b763c..ea49a13ad 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, LambdaCase, MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies, LambdaCase #-} module Semantic.Api.Bridge ( APIBridge (..) , APIConvert (..) From c316b20f074106fd5e0884a5c26256d209dedd73 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 16:25:59 -0500 Subject: [PATCH 08/32] Isolate the pattern of a ^? re b into its own combinator. --- src/Rendering/Graph.hs | 4 ++-- src/Semantic/Api/Bridge.hs | 17 ++++++++++++----- src/Semantic/Api/Symbols.hs | 2 +- src/Semantic/Api/TOCSummaries.hs | 4 ++-- 4 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 98d8e7895..ce575a397 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -73,7 +73,7 @@ instance (ConstructorName syntax, Foldable syntax) => termAlgebra (In ann syntax) = do i <- fresh parent <- ask - let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (locationSpan ann ^? re bridging)) + let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (bridging #? locationSpan ann)) subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax pure (parent `connect` root `overlay` subGraph) @@ -92,7 +92,7 @@ instance (ConstructorName syntax, Foldable syntax) => graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan)))) pure (parent `connect` replace `overlay` graph) where - ann a = a ^? to locationSpan . re bridging + ann a = bridging #? locationSpan a diffAlgebra :: ( Foldable f , Member Fresh sig diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index ea49a13ad..24a528b3e 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -2,6 +2,7 @@ module Semantic.Api.Bridge ( APIBridge (..) , APIConvert (..) + , (#?) ) where import Control.Lens @@ -13,6 +14,12 @@ import qualified Data.Text as T import qualified Semantic.Api.LegacyTypes as Legacy import qualified Semantic.Api.V1.CodeAnalysisPB as API +-- | A helper function for turning 'bridging' around and +-- extracting 'Just' values from it. +(#?) :: AReview t s -> s -> Maybe t +rev #? item = item ^? re rev +infixr 8 #? + class APIConvert api native | api -> native where converting :: Prism' api native @@ -31,13 +38,13 @@ instance APIBridge API.Position Data.Pos where instance APIBridge API.Span Data.Span where bridging = iso fromAPI toAPI where - toAPI Data.Span{..} = API.Span (spanStart ^? re bridging) (spanEnd ^? re bridging) + toAPI Data.Span{..} = API.Span (bridging #? spanStart) (bridging #? spanEnd) fromAPI API.Span{..} = Data.Span (start^.non single.bridging) (end^.non single.bridging) single = API.Position 1 1 instance APIConvert Legacy.Span Data.Span where converting = prism' dataToLegacy legacyToData where - dataToLegacy Data.Span{..} = Legacy.Span (spanStart ^? re bridging) (spanEnd ^? re bridging) + dataToLegacy Data.Span{..} = Legacy.Span (bridging #? spanStart) (bridging #? spanEnd) legacyToData Legacy.Span {..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging) instance APIBridge API.Language Data.Language where @@ -87,6 +94,6 @@ instance APIConvert API.BlobPair Data.BlobPair where apiBlobPairToBlobPair _ = Nothing - blobPairToApiBlobPair (Data.Diffing before after) = API.BlobPair (before ^? re bridging) (after ^? re bridging) - blobPairToApiBlobPair (Data.Inserting after) = API.BlobPair Nothing (after ^? re bridging) - blobPairToApiBlobPair (Data.Deleting before) = API.BlobPair (before ^? re bridging) Nothing + blobPairToApiBlobPair (Data.Diffing before after) = API.BlobPair (bridging #? before) (bridging #? after) + blobPairToApiBlobPair (Data.Inserting after) = API.BlobPair Nothing (bridging #? after) + blobPairToApiBlobPair (Data.Deleting before) = API.BlobPair (bridging #? before) Nothing diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index d563f233a..de685e484 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -75,6 +75,6 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut { symbol = name , kind = kind , line = fromMaybe mempty line - , span = span ^? re bridging + , span = bridging #? span , docs = fmap Docstring docs } diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index e3b1689f6..190e5197e 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -59,6 +59,6 @@ diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor blobs go go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile go TOCSummary{..} TOCSummaryFile{..} - = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (summarySpan ^? re bridging) (toChangeType summaryChangeType)) changes) errors + = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (bridging #? summarySpan) (toChangeType summaryChangeType)) changes) errors go ErrorSummary{..} TOCSummaryFile{..} - = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (errorSpan ^? re bridging)) errors) + = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (bridging #? errorSpan)) errors) From 37d697f0da2b546661c995917a3688bb4a2fda3c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 16:38:37 -0500 Subject: [PATCH 09/32] Remove unlawful lens. --- src/Rendering/Graph.hs | 4 ++-- src/Semantic/Api/Bridge.hs | 7 +++---- src/Semantic/Api/Symbols.hs | 2 +- src/Semantic/Api/TOCSummaries.hs | 4 ++-- 4 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index ce575a397..f45192149 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -73,7 +73,7 @@ instance (ConstructorName syntax, Foldable syntax) => termAlgebra (In ann syntax) = do i <- fresh parent <- ask - let root = vertex (TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (bridging #? locationSpan ann)) + let root = vertex $ TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (converting #? locationSpan ann) subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax pure (parent `connect` root `overlay` subGraph) @@ -92,7 +92,7 @@ instance (ConstructorName syntax, Foldable syntax) => graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan)))) pure (parent `connect` replace `overlay` graph) where - ann a = bridging #? locationSpan a + ann a = converting #? locationSpan a diffAlgebra :: ( Foldable f , Member Fresh sig diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index 24a528b3e..4a3152696 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -36,11 +36,10 @@ instance APIBridge API.Position Data.Pos where toAPI Data.Pos{..} = API.Position (fromIntegral posLine) (fromIntegral posColumn) fromAPI API.Position{..} = Data.Pos (fromIntegral line) (fromIntegral column) -instance APIBridge API.Span Data.Span where - bridging = iso fromAPI toAPI where +instance APIConvert API.Span Data.Span where + converting = prism' toAPI fromAPI where toAPI Data.Span{..} = API.Span (bridging #? spanStart) (bridging #? spanEnd) - fromAPI API.Span{..} = Data.Span (start^.non single.bridging) (end^.non single.bridging) - single = API.Position 1 1 + fromAPI API.Span{..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging) instance APIConvert Legacy.Span Data.Span where converting = prism' dataToLegacy legacyToData where diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index de685e484..2b599cf62 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -75,6 +75,6 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut { symbol = name , kind = kind , line = fromMaybe mempty line - , span = bridging #? span + , span = converting #? span , docs = fmap Docstring docs } diff --git a/src/Semantic/Api/TOCSummaries.hs b/src/Semantic/Api/TOCSummaries.hs index 190e5197e..c3eaab26f 100644 --- a/src/Semantic/Api/TOCSummaries.hs +++ b/src/Semantic/Api/TOCSummaries.hs @@ -59,6 +59,6 @@ diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor blobs go go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile go TOCSummary{..} TOCSummaryFile{..} - = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (bridging #? summarySpan) (toChangeType summaryChangeType)) changes) errors + = TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (converting #? summarySpan) (toChangeType summaryChangeType)) changes) errors go ErrorSummary{..} TOCSummaryFile{..} - = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (bridging #? errorSpan)) errors) + = TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors) From 6a0c0e67c561bcda6c50ca04bbabda0e31a95fe1 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 16:45:26 -0500 Subject: [PATCH 10/32] Document APIConvert and APIBridge. --- src/Semantic/Api/Bridge.hs | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index 4a3152696..c10d49831 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -14,18 +14,33 @@ import qualified Data.Text as T import qualified Semantic.Api.LegacyTypes as Legacy import qualified Semantic.Api.V1.CodeAnalysisPB as API +-- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@. +-- This is suitable for types such as 'Pos' which are representationally equal +-- in their API, legacy, and native forms. All 'Lens' laws apply. +-- +-- Foreign to native: @x^.bridging@ +-- Native to foreign: @bridging # x@ +-- Native to 'Just' foreign: @bridging #? x@. +class APIBridge api native | api -> native where + bridging :: Iso' api native + +-- | An @APIConvert x y@ instance describes a partial isomorphism between @x@ and @y@. +-- This is suitable for types containing nested records therein, such as 'Span'. +-- (The isomorphism must be partial, given that a protobuf record can have Nothing +-- for all its fields, which means we cannot convert to a native format.) +-- +-- Foreign to 'Maybe' native: @x^?converting@ +-- Native to foreign: @converting # x@ +-- Native to 'Just' foreign: @converting #? x@ +class APIConvert api native | api -> native where + converting :: Prism' api native + -- | A helper function for turning 'bridging' around and -- extracting 'Just' values from it. (#?) :: AReview t s -> s -> Maybe t rev #? item = item ^? re rev infixr 8 #? -class APIConvert api native | api -> native where - converting :: Prism' api native - -class APIBridge api native | api -> native where - bridging :: Iso' api native - instance APIBridge Legacy.Position Data.Pos where bridging = iso fromAPI toAPI where toAPI Data.Pos{..} = Legacy.Position posLine posColumn @@ -42,9 +57,9 @@ instance APIConvert API.Span Data.Span where fromAPI API.Span{..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging) instance APIConvert Legacy.Span Data.Span where - converting = prism' dataToLegacy legacyToData where - dataToLegacy Data.Span{..} = Legacy.Span (bridging #? spanStart) (bridging #? spanEnd) - legacyToData Legacy.Span {..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging) + converting = prism' toAPI fromAPI where + toAPI Data.Span{..} = Legacy.Span (bridging #? spanStart) (bridging #? spanEnd) + fromAPI Legacy.Span {..} = Data.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging) instance APIBridge API.Language Data.Language where bridging = iso apiLanguageToLanguage languageToApiLanguage where @@ -92,7 +107,6 @@ instance APIConvert API.BlobPair Data.BlobPair where apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Just $ Data.Inserting (after^.bridging) apiBlobPairToBlobPair _ = Nothing - blobPairToApiBlobPair (Data.Diffing before after) = API.BlobPair (bridging #? before) (bridging #? after) blobPairToApiBlobPair (Data.Inserting after) = API.BlobPair Nothing (bridging #? after) blobPairToApiBlobPair (Data.Deleting before) = API.BlobPair (bridging #? before) Nothing From ebbe50a08055eade872091a7477bac38db9e3f58 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 1 Mar 2019 16:54:02 -0500 Subject: [PATCH 11/32] Stray import --- src/Rendering/Graph.hs | 1 - src/Semantic/Api/Bridge.hs | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index f45192149..1fa8ae8c5 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -20,7 +20,6 @@ import Data.Term import Prologue import Semantic.Api.Bridge import Semantic.Api.V1.CodeAnalysisPB -import Control.Lens import qualified Data.Text as T diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index c10d49831..95a985b0b 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -21,6 +21,7 @@ import qualified Semantic.Api.V1.CodeAnalysisPB as API -- Foreign to native: @x^.bridging@ -- Native to foreign: @bridging # x@ -- Native to 'Just' foreign: @bridging #? x@. +-- Maybe 'Just' to 'Just' native: @x >>= preview bridging@ class APIBridge api native | api -> native where bridging :: Iso' api native From 5205e44e1c665451030bf19af9787e97d95258b2 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Sat, 2 Mar 2019 01:56:13 -0500 Subject: [PATCH 12/32] One more clarification in the docs. --- src/Semantic/Api/Bridge.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index 95a985b0b..1066aa397 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -30,6 +30,7 @@ class APIBridge api native | api -> native where -- (The isomorphism must be partial, given that a protobuf record can have Nothing -- for all its fields, which means we cannot convert to a native format.) -- +-- Foreign to native: this is a type error, unless the native is a Monoid -- Foreign to 'Maybe' native: @x^?converting@ -- Native to foreign: @converting # x@ -- Native to 'Just' foreign: @converting #? x@ From 9a71bdcc32fda80c5ddcaf571685ce51e44ee06c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Mar 2019 10:31:43 -0500 Subject: [PATCH 13/32] English is hard. --- src/Semantic/Api/Bridge.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index 1066aa397..c961ed00c 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -21,7 +21,7 @@ import qualified Semantic.Api.V1.CodeAnalysisPB as API -- Foreign to native: @x^.bridging@ -- Native to foreign: @bridging # x@ -- Native to 'Just' foreign: @bridging #? x@. --- Maybe 'Just' to 'Just' native: @x >>= preview bridging@ +-- 'Maybe' foreign to 'Maybe' native: @x >>= preview bridging@ class APIBridge api native | api -> native where bridging :: Iso' api native From aa2f6b2391a212e4e3fb05eb59ddfd5a8c4620a6 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Mar 2019 10:34:48 -0500 Subject: [PATCH 14/32] use #? properly --- src/Semantic/Api/Symbols.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 2b599cf62..9f2cc6b5d 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -49,7 +49,7 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap { symbolName = name , symbolKind = kind , symbolLine = fromMaybe mempty line - , symbolSpan = span ^? re converting + , symbolSpan = converting #? span } parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Builder From cd52b5d93271e76a2c84fc534ee13c7da6986aa4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 4 Mar 2019 10:44:20 -0500 Subject: [PATCH 15/32] Update src/Semantic/Api/Bridge.hs Co-Authored-By: patrickt --- src/Semantic/Api/Bridge.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index c961ed00c..dc5876058 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -15,7 +15,7 @@ import qualified Semantic.Api.LegacyTypes as Legacy import qualified Semantic.Api.V1.CodeAnalysisPB as API -- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@. --- This is suitable for types such as 'Pos' which are representationally equal +-- This is suitable for types such as 'Pos' which are representationally equivalent -- in their API, legacy, and native forms. All 'Lens' laws apply. -- -- Foreign to native: @x^.bridging@ From ae8b87a19cbe4e0fd7bdf9d9dd94320f603f7b4d Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Mar 2019 10:47:31 -0500 Subject: [PATCH 16/32] Bump fused-effects version. --- vendor/fused-effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/fused-effects b/vendor/fused-effects index f7e6b37ab..9bbf58dd7 160000 --- a/vendor/fused-effects +++ b/vendor/fused-effects @@ -1 +1 @@ -Subproject commit f7e6b37ab92a001b080f7749d3cc45ac3214f699 +Subproject commit 9bbf58dd7d87a3d89c9698abdcf9e52b6effbaf0 From 8285c3f68003733c016924fe8360c4a394d2b3ec Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Mar 2019 12:00:19 -0500 Subject: [PATCH 17/32] WIP --- src/Analysis/Abstract/Graph.hs | 2 +- src/Control/Abstract/Context.hs | 2 +- src/Control/Abstract/Evaluator.hs | 29 ++++++++++---------- src/Control/Abstract/Modules.hs | 24 ++++++++-------- src/Control/Abstract/ScopeGraph.hs | 9 +++--- src/Control/Abstract/Value.hs | 2 +- src/Control/Effect/Catch.hs | 41 ++++++++++++++-------------- src/Control/Effect/Interpose.hs | 35 ++++++++++++++---------- src/Control/Effect/REPL.hs | 10 +++---- src/Data/Abstract/Address/Hole.hs | 2 +- src/Data/Abstract/Address/Precise.hs | 2 +- src/Data/Graph.hs | 2 +- src/Diffing/Algorithm.hs | 5 ++-- src/Language/JSON/PrettyPrint.hs | 6 ++-- src/Language/Python/PrettyPrint.hs | 4 +-- src/Language/Ruby/PrettyPrint.hs | 4 +-- src/Rendering/Graph.hs | 2 +- src/Reprinting/Translate.hs | 6 ++-- src/Semantic/Api/Diffs.hs | 2 +- src/Semantic/Api/Symbols.hs | 4 +-- src/Semantic/Api/Terms.hs | 2 +- src/Semantic/Distribute.hs | 11 ++++---- src/Semantic/Graph.hs | 6 ++-- src/Semantic/Resolution.hs | 6 ++-- src/Semantic/Task.hs | 4 +-- src/Semantic/Task/Files.hs | 21 +++++++------- src/Semantic/Telemetry.hs | 16 +++++++---- src/Semantic/Timeout.hs | 26 ++++++++++-------- 28 files changed, 147 insertions(+), 138 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 385975dfa..8ae0b6271 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -202,7 +202,7 @@ variableDefinition var = do context <- ask appendGraph (vertex context `connect` vertex var) -appendGraph :: (Member (State (Graph v)) sig, Carrier sig m, Monad m) => Graph v -> m () +appendGraph :: (Member (State (Graph v)) sig, Carrier sig m) => Graph v -> m () appendGraph = modify . (<>) diff --git a/src/Control/Abstract/Context.hs b/src/Control/Abstract/Context.hs index 0195977e8..43ec632e4 100644 --- a/src/Control/Abstract/Context.hs +++ b/src/Control/Abstract/Context.hs @@ -45,7 +45,7 @@ currentSpan = ask withCurrentSpan :: (Member (Reader Span) sig, Carrier sig m) => Span -> m a -> m a withCurrentSpan = local . const -modifyChildSpan :: (Member (State Span) sig, Carrier sig m, Monad m) => Span -> m a -> m a +modifyChildSpan :: (Member (State Span) sig, Carrier sig m) => Span -> m a -> m a modifyChildSpan span m = m <* put span -- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'. diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 2b8f03c3e..e70c6d360 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -29,24 +29,19 @@ import Control.Effect.Trace as X import Control.Monad.IO.Class import Data.Coerce --- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the address, term, and value types. +-- | An 'Evaluator' is a thin wrapper around a monad with (phantom) type parameters for the address, term, and value types. -- -- These parameters enable us to constrain the types of effects using them s.t. we can avoid both ambiguous types when they aren’t mentioned outside of the context, and lengthy, redundant annotations on the use sites of functions employing these effects. -- -- These effects will typically include the environment, heap, module table, etc. effects necessary for evaluation of modules and terms, but may also include any other effects so long as they’re eventually handled. -newtype Evaluator term address value m a = Evaluator { runEvaluator :: Eff m a } - deriving (Applicative, Functor, Monad) - -deriving instance (Member NonDet sig, Carrier sig m) => Alternative (Evaluator term address value m) -deriving instance (Member (Lift IO) sig, Carrier sig m) => MonadIO (Evaluator term address value m) +newtype Evaluator term address value m a = Evaluator { runEvaluator :: m a } + deriving (Alternative, Applicative, Functor, Monad, MonadIO) instance Carrier sig m => Carrier sig (Evaluator term address value m) where - ret = Evaluator . ret - eff = Evaluator . eff . handlePure runEvaluator + eff = Evaluator . eff . handleCoercible - --- | Raise a handler on 'Eff's into a handler on 'Evaluator's. -raiseHandler :: (Eff m a -> Eff n b) +-- | Raise a handler on monads into a handler on 'Evaluator's over those monads. +raiseHandler :: (m a -> n b) -> Evaluator term address value m a -> Evaluator term address value n b raiseHandler = coerce @@ -69,10 +64,14 @@ earlyReturn :: ( Member (Error (Return value)) sig -> Evaluator term address value m value earlyReturn = throwError . Return -catchReturn :: (Member (Error (Return value)) sig, Carrier sig m) => Evaluator term address value m value -> Evaluator term address value m value +catchReturn :: (Member (Error (Return value)) sig, Carrier sig m) + => Evaluator term address value m value + -> Evaluator term address value m value catchReturn = flip catchError (\ (Return value) -> pure value) -runReturn :: (Carrier sig m, Effect sig) => Evaluator term address value (ErrorC (Return value) (Eff m)) value -> Evaluator term address value m value +runReturn :: Carrier sig m + => Evaluator term address value (ErrorC (Return value) m) value + -> Evaluator term address value m value runReturn = raiseHandler $ fmap (either unReturn id) . runError @@ -105,7 +104,7 @@ catchLoopControl :: ( Member (Error (LoopControl value)) sig -> Evaluator term address value m a catchLoopControl = catchError -runLoopControl :: (Carrier sig m, Effect sig) - => Evaluator term address value (ErrorC (LoopControl value) (Eff m)) value +runLoopControl :: Carrier sig m + => Evaluator term address value (ErrorC (LoopControl value) m) value -> Evaluator term address value m value runLoopControl = raiseHandler $ fmap (either unLoopControl id) . runError diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index d9dc10c5a..79e7bf028 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Control.Abstract.Modules ( ModuleResult , lookupModule @@ -87,24 +87,26 @@ runModules :: ( Member (Reader (ModuleTable (Module (ModuleResult address value) , Carrier sig m ) => Set ModulePath - -> Evaluator term address value (ModulesC address value (Eff m)) a + -> Evaluator term address value (ModulesC address value m) a -> Evaluator term address value m a -runModules paths = raiseHandler $ flip runModulesC paths . interpret +runModules paths = raiseHandler $ flip runModulesC paths -newtype ModulesC address value m a = ModulesC { runModulesC :: Set ModulePath -> m a } +newtype ModulesC address value m a = ModulesC { runModulesC :: ReaderC (Set ModulePath) m a } + deriving (Alternative, Applicative, Functor, Monad, MonadIO) instance ( Member (Reader (ModuleTable (Module (ModuleResult address value)))) sig , Member (Resumable (BaseError (LoadError address value))) sig , Carrier sig m - , Monad m ) => Carrier (Modules address value :+: sig) (ModulesC address value m) where - ret = ModulesC . const . ret - eff op = ModulesC (\ paths -> handleSum (eff . handleReader paths runModulesC) (\case - Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap moduleBody . ModuleTable.lookup name >>= flip runModulesC paths . k - Lookup path k -> askModuleTable >>= flip runModulesC paths . k . fmap moduleBody . ModuleTable.lookup path - Resolve names k -> runModulesC (k (find (`Set.member` paths) names)) paths - List dir k -> runModulesC (k (filter ((dir ==) . takeDirectory) (toList paths))) paths) op) + eff (L op) = do + paths <- ModulesC ask + case op of + Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap moduleBody . ModuleTable.lookup name >>= k + Lookup path k -> askModuleTable >>= k . fmap moduleBody . ModuleTable.lookup path + Resolve names k -> k (find (`Set.member` paths)) + List dir k -> k (filter ((dir ==) . takeDirectory) (toList paths)) + eff (R other) = ModulesC (eff (R (handleCoercible other))) askModuleTable :: (Member (Reader (ModuleTable (Module (ModuleResult address value)))) sig, Carrier sig m) => m (ModuleTable (Module (ModuleResult address value))) askModuleTable = ask diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index d6f69cd8a..268722098 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -367,15 +367,14 @@ instance HFunctor (Allocator address) where instance Effect (Allocator address) where handle state handler (Alloc name k) = Alloc name (handler . (<$ state) . k) -runAllocator :: Carrier (Allocator address :+: sig) (AllocatorC address (Eff m)) - => Evaluator term address value (AllocatorC address (Eff m)) a +runAllocator :: Carrier (Allocator address :+: sig) (AllocatorC address m) + => Evaluator term address value (AllocatorC address m) a -> Evaluator term address value m a -runAllocator = raiseHandler $ runAllocatorC . interpret +runAllocator = raiseHandler runAllocatorC newtype AllocatorC address m a = AllocatorC { runAllocatorC :: m a } deriving (Alternative, Applicative, Functor, Monad) - runScopeErrorWith :: Carrier sig m => (forall resume . BaseError (ScopeError address) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) (Eff m)) a @@ -383,6 +382,6 @@ runScopeErrorWith :: Carrier sig m runScopeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) runScopeError :: (Carrier sig m, Effect sig) - => Evaluator term address value (ResumableC (BaseError (ScopeError address)) (Eff m)) a + => Evaluator term address value (ResumableC (BaseError (ScopeError address)) m) a -> Evaluator term address value m (Either (SomeError (BaseError (ScopeError address))) a) runScopeError = raiseHandler runResumable diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index b0c97b421..31c429fb2 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -156,7 +156,7 @@ asBool :: (Member (Boolean value) sig, Carrier sig m) => value -> m Bool asBool = send . flip AsBool ret -- | Eliminate boolean values. TODO: s/boolean/truthy -ifthenelse :: (Member (Boolean value) sig, Carrier sig m, Monad m) => value -> m a -> m a -> m a +ifthenelse :: (Member (Boolean value) sig, Carrier sig m) => value -> m a -> m a -> m a ifthenelse v t e = asBool v >>= \ c -> if c then t else e data Boolean value (m :: * -> *) k diff --git a/src/Control/Effect/Catch.hs b/src/Control/Effect/Catch.hs index 2c23e059f..2dfbe78c6 100644 --- a/src/Control/Effect/Catch.hs +++ b/src/Control/Effect/Catch.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, LambdaCase, - MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, + LambdaCase, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} -- | An effect that enables catching exceptions thrown from -- impure computations such as IO. @@ -11,7 +11,7 @@ module Control.Effect.Catch ) where import Control.Effect.Carrier -import Control.Effect.Internal +import Control.Effect.Reader import Control.Effect.Sum import qualified Control.Exception as Exc import Control.Monad.IO.Class @@ -37,26 +37,25 @@ catch :: (Member Catch sig, Carrier sig m, Exc.Exception e) => m a -> (e -> m a) -> m a -catch go cleanup = send (CatchIO go cleanup ret) +catch go cleanup = send (CatchIO go cleanup pure) -runCatch :: (Carrier sig m, MonadIO m) - => (forall x . m x -> IO x) - -> Eff (CatchC m) a - -> m a -runCatch handler = runCatchC handler . interpret -newtype CatchC m a = CatchC ((forall x . m x -> IO x) -> m a) +-- | Evaulate a 'Catch' effect. +runCatch :: (forall x . m x -> IO x) + -> CatchC m a + -> m a +runCatch handler = runReader (Handler handler) . runCatchC -runCatchC :: (forall x . m x -> IO x) -> CatchC m a -> m a -runCatchC handler (CatchC m) = m handler +newtype Handler m = Handler (forall x . m x -> IO x) + +runHandler :: Handler m -> CatchC m a -> IO a +runHandler h@(Handler handler) = handler . runReader h . runCatchC + +newtype CatchC m a = CatchC { runCatchC :: ReaderC (Handler m) m a } + deriving (Functor, Applicative, Monad, MonadIO) instance (Carrier sig m, MonadIO m) => Carrier (Catch :+: sig) (CatchC m) where - ret a = CatchC (const (ret a)) - eff op = CatchC (\ handler -> handleSum - (eff . handlePure (runCatchC handler)) - (\case - CatchIO go cleanup k -> liftIO (Exc.catch - (handler (runCatchC handler go)) - (handler . runCatchC handler . cleanup)) - >>= runCatchC handler . k - ) op) + eff (L (CatchIO act cleanup k)) = do + handler <- CatchC ask + liftIO (Exc.catch (runHandler handler act) (runHandler handler . cleanup)) >>= k + eff (R other) = CatchC (eff (R (handleCoercible other))) diff --git a/src/Control/Effect/Interpose.hs b/src/Control/Effect/Interpose.hs index 553f9cf26..b6e0a5efe 100644 --- a/src/Control/Effect/Interpose.hs +++ b/src/Control/Effect/Interpose.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Control.Effect.Interpose ( Interpose(..) , interpose @@ -7,8 +7,9 @@ module Control.Effect.Interpose , Listener(..) ) where +import Control.Applicative import Control.Effect.Carrier -import Control.Effect.Internal +import Control.Effect.Reader import Control.Effect.Sum data Interpose eff m k @@ -28,22 +29,26 @@ interpose :: (Member (Interpose eff) sig, Carrier sig m) => m a -> (forall n x . eff n (n x) -> m x) -> m a -interpose m f = send (Interpose m f ret) +interpose m f = send (Interpose m f pure) -- | Run an 'Interpose' effect. -runInterpose :: (Member eff sig, Carrier sig m, Monad m) => Eff (InterposeC eff m) a -> m a -runInterpose = flip runInterposeC Nothing . interpret +runInterpose :: InterposeC eff m a -> m a +runInterpose = runReader Nothing . runInterposeC -newtype InterposeC eff m a = InterposeC { runInterposeC :: Maybe (Listener eff m) -> m a } +newtype InterposeC eff m a = InterposeC { runInterposeC :: ReaderC (Maybe (Listener eff m)) m a } + deriving (Alternative, Applicative, Functor, Monad) -newtype Listener eff m = Listener { runListener :: forall n x . eff n (n x) -> m x } +newtype Listener eff m = Listener (forall n x . eff n (n x) -> m x) -instance (Carrier sig m, Member eff sig, Monad m) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where - ret a = InterposeC (const (ret a)) - eff op = InterposeC (\ listener -> handleSum (algOther listener) (alg listener) op) - where alg listener (Interpose m h k) = runInterposeC m (Just (Listener (flip runInterposeC listener . h))) >>= flip runInterposeC listener . k - algOther listener op - | Just listener <- listener - , Just eff <- prj op = runListener listener eff - | otherwise = eff (handleReader listener runInterposeC op) +runListener :: Listener eff m -> eff (InterposeC eff m) (InterposeC eff m a) -> InterposeC eff m a +runListener l@(Listener listen) = undefined --listen . runReader (Just l) . runInterposeC + +instance (Carrier sig m, Member eff sig) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where + eff (L (Interpose m h k)) = + local (const _) m >>= k + eff (R other) = do + listener <- InterposeC ask + case (listener, prj other) of + (Just listener, Just eff) -> runListener listener eff + _ -> InterposeC (eff (R (handleCoercible other))) diff --git a/src/Control/Effect/REPL.hs b/src/Control/Effect/REPL.hs index 25ab983e6..329ae2825 100644 --- a/src/Control/Effect/REPL.hs +++ b/src/Control/Effect/REPL.hs @@ -34,16 +34,16 @@ prompt p = send (Prompt p ret) output :: (Member REPL sig, Carrier sig m) => Text -> m () output s = send (Output s (ret ())) -runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a +runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> REPLC m a -> m a runREPL prefs settings = flip runREPLC (prefs, settings) . interpret newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a } instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where - ret = REPLC . const . ret - eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case - Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= flip runREPLC args . k - Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> runREPLC k args) op) + eff (L (Prompt p k)) = REPLC (liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= k) + eff (L (Output s k)) = REPLC (liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> k) + eff (R other) = REPLC (eff (handleCoercible other)) + cyan :: String cyan = "\ESC[1;36m\STX" diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index 85a6dfa1b..84a789e06 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -37,7 +37,7 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m) promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a promoteD = DerefC . runDerefC -instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m, Monad m) +instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m) => Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where ret = promoteD . ret eff = handleSum (DerefC . eff . handleCoercible) (\case diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index ba907fef6..0080f5595 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -18,7 +18,7 @@ instance Show Precise where showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise -instance (Member Fresh sig, Carrier sig m, Monad m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where +instance (Member Fresh sig, Carrier sig m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where ret = AllocatorC . ret eff = AllocatorC . handleSum (eff . handleCoercible) diff --git a/src/Data/Graph.hs b/src/Data/Graph.hs index 52820b4ea..2944bffeb 100644 --- a/src/Data/Graph.hs +++ b/src/Data/Graph.hs @@ -49,7 +49,7 @@ topologicalSort = go . Class.toAdjacencyMap . G.transpose . unGraph . traverse_ visit . A.vertexList $ graph - where visit :: (Member (State (Visited v)) sig, Carrier sig m, Monad m) => v -> m () + where visit :: (Member (State (Visited v)) sig, Carrier sig m) => v -> m () visit v = do isMarked <- Set.member v . visitedVertices <$> get if isMarked then diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index 3672aa594..9b83a2168 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -47,14 +47,13 @@ instance Effect (Diff term1 term2 diff) where handle state handler = coerce . fmap (handler . (<$ state)) -newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: Eff m a } +newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: m a } deriving (Applicative, Functor, Monad) deriving instance (Carrier sig m, Member NonDet sig) => Alternative (Algorithm term1 term2 diff m) instance Carrier sig m => Carrier sig (Algorithm term1 term2 diff m) where - ret = Algorithm . ret - eff = Algorithm . eff . handleCoercible + eff = Algorithm . eff -- DSL diff --git a/src/Language/JSON/PrettyPrint.hs b/src/Language/JSON/PrettyPrint.hs index b34349f48..0f9c8550a 100644 --- a/src/Language/JSON/PrettyPrint.hs +++ b/src/Language/JSON/PrettyPrint.hs @@ -19,7 +19,7 @@ import Data.Reprinting.Token import Data.Reprinting.Scope -- | Default printing pipeline for JSON. -defaultJSONPipeline :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) +defaultJSONPipeline :: (Member (Error TranslationError) sig, Carrier sig m) => ProcessT m Fragment Splice defaultJSONPipeline = printingJSON @@ -56,7 +56,7 @@ defaultBeautyOpts :: JSONBeautyOpts defaultBeautyOpts = JSONBeautyOpts 2 False -- | Produce JSON with configurable whitespace and layout. -beautifyingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) +beautifyingJSON :: (Member (Error TranslationError) sig, Carrier sig m) => JSONBeautyOpts -> ProcessT m Fragment Splice beautifyingJSON _ = repeatedly (await >>= step) where step (Defer el cs) = lift (throwError (NoTranslation el cs)) @@ -70,7 +70,7 @@ beautifyingJSON _ = repeatedly (await >>= step) where _ -> emit txt -- | Produce whitespace minimal JSON. -minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) +minimizingJSON :: (Member (Error TranslationError) sig, Carrier sig m) => ProcessT m Fragment Splice minimizingJSON = repeatedly (await >>= step) where step (Defer el cs) = lift (throwError (NoTranslation el cs)) diff --git a/src/Language/Python/PrettyPrint.hs b/src/Language/Python/PrettyPrint.hs index e144bb0f8..00f0854fe 100644 --- a/src/Language/Python/PrettyPrint.hs +++ b/src/Language/Python/PrettyPrint.hs @@ -14,10 +14,10 @@ import Data.Reprinting.Scope import Data.Reprinting.Operator -- | Print Python syntax. -printingPython :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice +printingPython :: (Member (Error TranslationError) sig, Carrier sig m) => ProcessT m Fragment Splice printingPython = repeatedly (await >>= step) -step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m () +step :: (Member (Error TranslationError) sig, Carrier sig m) => Fragment -> PlanT k Splice m () step (Verbatim txt) = emit txt step (New _ _ txt) = emit txt step (Defer el cs) = case (el, cs) of diff --git a/src/Language/Ruby/PrettyPrint.hs b/src/Language/Ruby/PrettyPrint.hs index 1f943f5e3..6b6abbcce 100644 --- a/src/Language/Ruby/PrettyPrint.hs +++ b/src/Language/Ruby/PrettyPrint.hs @@ -14,10 +14,10 @@ import Data.Reprinting.Splice import Data.Reprinting.Token as Token -- | Print Ruby syntax. -printingRuby :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => ProcessT m Fragment Splice +printingRuby :: (Member (Error TranslationError) sig, Carrier sig m) => ProcessT m Fragment Splice printingRuby = repeatedly (await >>= step) -step :: (Member (Error TranslationError) sig, Carrier sig m, Monad m) => Fragment -> PlanT k Splice m () +step :: (Member (Error TranslationError) sig, Carrier sig m) => Fragment -> PlanT k Splice m () step (Verbatim txt) = emit txt step (New _ _ txt) = emit txt step (Defer el cs) = case (el, cs) of diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index f30a72db5..2caad9d5a 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -54,7 +54,7 @@ diffStyle name = (defaultStyle (fromString . show . diffVertexId)) vertexAttributes _ = [] class ToTreeGraph vertex t | t -> vertex where - toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m, Monad m) => t (m (Graph vertex)) -> m (Graph vertex) + toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m) => t (m (Graph vertex)) -> m (Graph vertex) instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph TermVertex (TermF syntax Location) where diff --git a/src/Reprinting/Translate.hs b/src/Reprinting/Translate.hs index 9e9ff0c7c..ec06426da 100644 --- a/src/Reprinting/Translate.hs +++ b/src/Reprinting/Translate.hs @@ -19,9 +19,9 @@ import Data.Reprinting.Scope import qualified Data.Source as Source type Translator - = Eff (StateC [Scope] - ( Eff (ErrorC TranslationError - ( Eff VoidC)))) + = StateC [Scope] + ( ErrorC TranslationError + ( VoidC )) contextualizing :: ProcessT Translator Token Fragment contextualizing = repeatedly $ await >>= \case diff --git a/src/Semantic/Api/Diffs.hs b/src/Semantic/Api/Diffs.hs index d42e8e50b..7ddccb62a 100644 --- a/src/Semantic/Api/Diffs.hs +++ b/src/Semantic/Api/Diffs.hs @@ -124,7 +124,7 @@ diffTerms blobs terms = time "diff" languageTag $ do diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) where languageTag = languageTagForBlobPair blobs -doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Carrier sig m, Monad m) +doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Carrier sig m) => BlobPair -> Decorate m Location ann -> m (SomeTermPair TermPairConstraints ann) doParse blobPair decorate = case languageForBlobPair blobPair of Go -> SomeTermPair <$> distributeFor blobPair (\ blob -> parse goParser blob >>= decorate blob) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index a78d34bf9..ec4785a90 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -32,7 +32,7 @@ import Tags.Tagging legacyParseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs where - go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Blob -> m [Legacy.File] + go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m [Legacy.File] go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException _) -> pure (pure emptyFile)) where emptyFile = Legacy.File (pack blobPath) (pack (show blobLanguage)) [] @@ -57,7 +57,7 @@ parseSymbolsBuilder blobs = parseSymbols blobs >>= serialize JSON parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go where - go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Blob -> m File + go :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m File go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException e) -> pure $ errorFile (show e)) where errorFile e = File (pack blobPath) (languageToApiLanguage blobLanguage) mempty (V.fromList [ParseError (T.pack e)]) diff --git a/src/Semantic/Api/Terms.hs b/src/Semantic/Api/Terms.hs index 9bf5ad7a3..fd12e48eb 100644 --- a/src/Semantic/Api/Terms.hs +++ b/src/Semantic/Api/Terms.hs @@ -101,7 +101,7 @@ quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fma in stringUtf8 (status <> "\t" <> show blobLanguage <> "\t" <> blobPath <> "\t" <> show duration <> " ms\n") -type ParseEffects sig m = (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) +type ParseEffects sig m = (Member (Error SomeException) sig, Member Task sig, Carrier sig m) type TermConstraints = '[ Taggable diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index 34c789a41..96fafb2ca 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -48,13 +48,12 @@ instance Effect Distribute where -- | Evaluate a 'Distribute' effect concurrently. -runDistribute :: Eff (DistributeC (Eff (LiftC IO))) a -> Eff (LiftC IO) a -runDistribute = runDistributeC . interpret +runDistribute :: DistributeC (LiftC IO) a -> Eff (LiftC IO) a +runDistribute = runDistributeC newtype DistributeC m a = DistributeC { runDistributeC :: m a } + deriving (Functor, Applicative, Monad) instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where - ret = DistributeC . ret - eff = DistributeC . handleSum - (eff . handleCoercible) - (\ (Distribute task k) -> liftIO (Async.runConcurrently (Async.Concurrently (runM (runDistributeC task)))) >>= runDistributeC . k) + eff (L (Distribute task k)) = liftIO (Async.runConcurrently (Async.Concurrently (runM task))) >>= k + eff (R other) = DistributeC (eff (handleCoercible other)) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index e0778d76c..e75fab4ec 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -231,7 +231,7 @@ runScopeGraph :: (Carrier sig m, Effect sig, Ord address) runScopeGraph = raiseHandler (runState lowerBound) -- | Parse a list of files into a 'Package'. -parsePackage :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m, Monad m) +parsePackage :: (Member Distribute sig, Member (Error SomeException) sig, Member Resolution sig, Member Task sig, Member Trace sig, Carrier sig m) => Parser term -- ^ A parser. -> Project -- ^ Project to parse into a package. -> m (Package (Blob, term)) @@ -245,7 +245,7 @@ parsePackage parser project = do n = Data.Abstract.Evaluatable.name (projectName project) -- TODO: Confirm this is the right `name`. -- | Parse all files in a project into 'Module's. -parseModules :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) => Parser term -> Project -> m [Module (Blob, term)] +parseModules :: (Member Distribute sig, Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Parser term -> Project -> m [Module (Blob, term)] parseModules parser p@Project{..} = distributeFor (projectFiles p) (parseModule p parser) @@ -321,7 +321,7 @@ parsePythonPackage parser project = do resMap <- Task.resolutionMap p pure (Package.fromModules (Data.Abstract.Evaluatable.name $ projectName p) modules resMap) -- TODO: Confirm this is the right `name`. -parseModule :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Monad m) +parseModule :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Project -> Parser term -> File diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index ce8bfda59..1a67c0f21 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -24,7 +24,7 @@ import Semantic.Task.Files import System.FilePath.Posix -nodeJSResolutionMap :: (Member Files sig, Carrier sig m, Monad m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath) +nodeJSResolutionMap :: (Member Files sig, Carrier sig m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath) nodeJSResolutionMap rootDir prop excludeDirs = do files <- findFiles rootDir [".json"] excludeDirs let packageFiles = file <$> filter ((==) "package.json" . takeFileName) files @@ -57,12 +57,12 @@ instance Effect Resolution where handle state handler (NodeJSResolution path key paths k) = NodeJSResolution path key paths (handler . (<$ state) . k) handle state handler (NoResolution k) = NoResolution (handler . (<$ state) . k) -runResolution :: (Member Files sig, Carrier sig m, Monad m) => Eff (ResolutionC m) a -> m a +runResolution :: (Member Files sig, Carrier sig m) => Eff (ResolutionC m) a -> m a runResolution = runResolutionC . interpret newtype ResolutionC m a = ResolutionC { runResolutionC :: m a } -instance (Member Files sig, Carrier sig m, Monad m) => Carrier (Resolution :+: sig) (ResolutionC m) where +instance (Member Files sig, Carrier sig m) => Carrier (Resolution :+: sig) (ResolutionC m) where ret = ResolutionC . ret eff = ResolutionC . handleSum (eff . handleCoercible) (\case NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 430a1de9b..3ad15c3ad 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -191,14 +191,14 @@ withOptions options with = do config <- defaultConfig options withTelemetry config (\ (TelemetryQueues logger statter _) -> with config logger statter) -runTraceInTelemetry :: (Member Telemetry sig, Carrier sig m, Monad m) +runTraceInTelemetry :: (Member Telemetry sig, Carrier sig m) => Eff (TraceInTelemetryC m) a -> m a runTraceInTelemetry = runTraceInTelemetryC . interpret newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a } -instance (Member Telemetry sig, Carrier sig m, Monad m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where +instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where ret = TraceInTelemetryC . ret eff = TraceInTelemetryC . handleSum (eff . handleCoercible) diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index a2e6e9a42..5203d411d 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -59,22 +59,23 @@ instance Effect Files where handle state handler (Write destination builder k) = Write destination builder (handler (k <$ state)) -- | Run a 'Files' effect in 'IO'. -runFiles :: (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Eff (FilesC m) a -> m a -runFiles = runFilesC . interpret +runFiles :: (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => FilesC m a -> m a +runFiles = runFilesC newtype FilesC m a = FilesC { runFilesC :: m a } + deriving (Functor, Applicative, Monad) instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where - ret = FilesC . ret - eff = FilesC . handleSum (eff . handleCoercible) (\case - Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - Read (FromHandle handle) k -> (readBlobsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k - FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= runFilesC . k + eff (L op) = case op of + Read (FromPath path) k -> (readBlobFromFile' path `catchIO` (throwError . toException @SomeException)) >>= k + Read (FromHandle handle) k -> (readBlobsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= k + Read (FromPathPair paths) k -> (runBothWith readFilePair paths `catchIO` (throwError . toException @SomeException)) >>= k + Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= k + ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= k + FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= k Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> runFilesC k Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k) + eff (R other) = FilesC (eff (handleCoercible other)) readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index c4515beb7..d147eb81b 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -151,16 +151,20 @@ instance Effect Telemetry where handle state handler (WriteLog level message pairs k) = WriteLog level message pairs (handler (k <$ state)) -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. -runTelemetry :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> Eff (TelemetryC m) a -> m a -runTelemetry logger statter = flip runTelemetryC (logger, statter) . interpret +runTelemetry :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> TelemetryC m a -> m a +runTelemetry logger statter = flip runTelemetryC (logger, statter) newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) -> m a } + deriving stock Functor + deriving (Applicative, Monad) via (ReaderC (LogQueue, StatQueue)) instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where - ret = TelemetryC . const . ret - eff op = TelemetryC (\ queues -> handleSum (eff . handleReader queues runTelemetryC) (\case - WriteStat stat k -> queueStat (snd queues) stat *> runTelemetryC k queues - WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) op) + eff (L op) = TelemetryC (\ queues -> case op of + WriteStat stat k -> queueStat (snd queues) stat *> runTelemetryC k queues + WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) + eff (R other) = TelemetryC (\queues -> eff (handlePure (flip runTelemetryC queues) other)) + + -- | Run a 'Telemetry' effect by ignoring statting/logging. diff --git a/src/Semantic/Timeout.hs b/src/Semantic/Timeout.hs index 3af68f870..3a91f097b 100644 --- a/src/Semantic/Timeout.hs +++ b/src/Semantic/Timeout.hs @@ -33,20 +33,22 @@ instance HFunctor Timeout where instance Effect Timeout where handle state handler (Timeout n task k) = Timeout n (handler (task <$ state)) (handler . maybe (k Nothing <$ state) (fmap (k . Just))) --- | Evaulate a 'Timeoute' effect. -runTimeout :: (Carrier sig m, MonadIO m) - => (forall x . m x -> IO x) - -> Eff (TimeoutC m) a +-- | Evaulate a 'Timeout' effect. +runTimeout :: (forall x . m x -> IO x) + -> TimeoutC m a -> m a -runTimeout handler = runTimeoutC handler . interpret +runTimeout handler = runReader (Handler handler) . runTimeoutC -newtype TimeoutC m a = TimeoutC ((forall x . m x -> IO x) -> m a) +newtype Handler m = Handler (forall x . m x -> IO x) -runTimeoutC :: (forall x . m x -> IO x) -> TimeoutC m a -> m a -runTimeoutC f (TimeoutC m) = m f +runHandler :: Handler m -> TimeoutC m a -> IO a +runHandler h@(Handler handler) = handler . runReader h . runTimeoutC + +newtype TimeoutC m a = TimeoutC { runTimeoutC :: ReaderC (Handler m) m a } + deriving (Functor, Applicative, Monad, MonadIO) instance (Carrier sig m, MonadIO m) => Carrier (Timeout :+: sig) (TimeoutC m) where - ret a = TimeoutC (const (ret a)) - eff op = TimeoutC (\ handler -> handleSum - (eff . handlePure (runTimeoutC handler)) - (\ (Timeout n task k) -> liftIO (System.timeout (toMicroseconds n) (handler (runTimeoutC handler task))) >>= runTimeoutC handler . k) op) + eff (L (Timeout n task k)) = do + handler <- TimeoutC ask + liftIO (System.timeout (toMicroseconds n) (runHandler handler task)) >>= k + eff (R other) = TimeoutC (eff (R (handleCoercible other))) From 6eb1fe3403b4310ce46d06ecc3787f9957ab7457 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Mar 2019 12:54:21 -0500 Subject: [PATCH 18/32] WIP --- src/Control/Abstract/Heap.hs | 27 +++---- src/Control/Abstract/Modules.hs | 34 ++++----- src/Control/Abstract/ScopeGraph.hs | 13 ++-- src/Control/Abstract/Value.hs | 119 ++++++++++++++--------------- src/Control/Effect/Interpose.hs | 10 ++- src/Control/Effect/REPL.hs | 23 +++--- src/Diffing/Algorithm.hs | 30 ++++---- src/Diffing/Interpreter.hs | 22 +++--- src/Rendering/Graph.hs | 6 +- src/Semantic/Telemetry.hs | 20 +++-- src/Semantic/Timeout.hs | 2 +- 11 files changed, 147 insertions(+), 159 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 7ec6ab8f0..1ba00b4cb 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -222,7 +222,7 @@ deref :: ( Member (Deref value) sig deref slot@Slot{..} = do maybeSlotValue <- gets (Heap.getSlotValue slot) slotValue <- maybeM (throwAddressError (UnallocatedSlot slot)) maybeSlotValue - eff <- send $ DerefCell slotValue ret + eff <- send $ DerefCell slotValue pure maybeM (throwAddressError $ UninitializedSlot slot) eff putSlotDeclarationScope :: ( Member (State (Heap address address value)) sig @@ -375,7 +375,7 @@ assign :: ( Member (Deref value) sig -> Evaluator term address value m () assign addr value = do heap <- getHeap - cell <- send (AssignCell value (fromMaybe lowerBound (Heap.getSlotValue addr heap)) ret) + cell <- send (AssignCell value (fromMaybe lowerBound (Heap.getSlotValue addr heap)) pure) putHeap (Heap.setSlot addr cell heap) dealloc :: ( Carrier sig m @@ -431,10 +431,9 @@ instance Effect (Deref value) where handle state handler (DerefCell cell k) = DerefCell cell (handler . (<$ state) . k) handle state handler (AssignCell value cell k) = AssignCell value cell (handler . (<$ state) . k) -runDeref :: Carrier (Deref value :+: sig) (DerefC address value (Eff m)) - => Evaluator term address value (DerefC address value (Eff m)) a +runDeref :: Evaluator term address value (DerefC address value m) a -> Evaluator term address value m a -runDeref = raiseHandler $ runDerefC . interpret +runDeref = raiseHandler runDerefC newtype DerefC address value m a = DerefC { runDerefC :: m a } deriving (Alternative, Applicative, Functor, Monad) @@ -481,14 +480,12 @@ throwHeapError :: ( Member (Resumable (BaseError (HeapError address))) sig -> Evaluator term address value m resume throwHeapError = throwBaseError -runHeapError :: (Carrier sig m, Effect sig) - => Evaluator term address value (ResumableC (BaseError (HeapError address)) (Eff m)) a - -> Evaluator term address value m (Either (SomeError (BaseError (HeapError address))) a) +runHeapError :: Evaluator term address value (ResumableC (BaseError (HeapError address)) m) a + -> Evaluator term address value m (Either (SomeError (BaseError (HeapError address))) a) runHeapError = raiseHandler runResumable -runHeapErrorWith :: Carrier sig m - => (forall resume. (BaseError (HeapError address)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (HeapError address)) (Eff m)) a +runHeapErrorWith :: (forall resume. (BaseError (HeapError address)) resume -> Evaluator term address value m resume) + -> Evaluator term address value (ResumableWithC (BaseError (HeapError address)) m) a -> Evaluator term address value m a runHeapErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) @@ -522,13 +519,11 @@ throwAddressError :: ( Member (Resumable (BaseError (AddressError address body)) -> Evaluator term address value m resume throwAddressError = throwBaseError -runAddressError :: (Carrier sig m, Effect sig) - => Evaluator term address value (ResumableC (BaseError (AddressError address value)) (Eff m)) a +runAddressError :: Evaluator term address value (ResumableC (BaseError (AddressError address value)) m) a -> Evaluator term address value m (Either (SomeError (BaseError (AddressError address value))) a) runAddressError = raiseHandler runResumable -runAddressErrorWith :: Carrier sig m - => (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff m)) a +runAddressErrorWith :: (forall resume . (BaseError (AddressError address value)) resume -> Evaluator term address value m resume) + -> Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) m) a -> Evaluator term address value m a runAddressErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 79e7bf028..133120e78 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -36,14 +36,14 @@ type ModuleResult address value = ((address, address), value) -- | Retrieve an evaluated module, if any. @Nothing@ means we’ve never tried to load it, and @Just (env, value)@ indicates the result of a completed load. lookupModule :: (Member (Modules address value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (Maybe (ModuleResult address value)) -lookupModule = sendModules . flip Lookup ret +lookupModule = sendModules . flip Lookup pure -- | Resolve a list of module paths to a possible module table entry. resolve :: (Member (Modules address value) sig, Carrier sig m) => [FilePath] -> Evaluator term address value m (Maybe ModulePath) -resolve = sendModules . flip Resolve ret +resolve = sendModules . flip Resolve pure listModulesInDir :: (Member (Modules address value) sig, Carrier sig m) => FilePath -> Evaluator term address value m [ModulePath] -listModulesInDir = sendModules . flip List ret +listModulesInDir = sendModules . flip List pure -- | Require/import another module by name and return its environment and value. @@ -56,7 +56,7 @@ require path = lookupModule path >>= maybeM (load path) -- -- Always loads/evaluates. load :: (Member (Modules address value) sig, Carrier sig m) => ModulePath -> Evaluator term address value m (ModuleResult address value) -load path = sendModules (Load path ret) +load path = sendModules (Load path pure) data Modules address value (m :: * -> *) k @@ -82,14 +82,10 @@ sendModules :: ( Member (Modules address value) sig -> Evaluator term address value m return sendModules = send -runModules :: ( Member (Reader (ModuleTable (Module (ModuleResult address value)))) sig - , Member (Resumable (BaseError (LoadError address value))) sig - , Carrier sig m - ) - => Set ModulePath +runModules :: Set ModulePath -> Evaluator term address value (ModulesC address value m) a -> Evaluator term address value m a -runModules paths = raiseHandler $ flip runModulesC paths +runModules paths = raiseHandler (runReader paths . runModulesC) newtype ModulesC address value m a = ModulesC { runModulesC :: ReaderC (Set ModulePath) m a } deriving (Alternative, Applicative, Functor, Monad, MonadIO) @@ -104,7 +100,7 @@ instance ( Member (Reader (ModuleTable (Module (ModuleResult address value)))) s case op of Load name k -> askModuleTable >>= maybeM (throwLoadError (ModuleNotFoundError name)) . fmap moduleBody . ModuleTable.lookup name >>= k Lookup path k -> askModuleTable >>= k . fmap moduleBody . ModuleTable.lookup path - Resolve names k -> k (find (`Set.member` paths)) + Resolve names k -> k (find (`Set.member` paths) names) List dir k -> k (filter ((dir ==) . takeDirectory) (toList paths)) eff (R other) = ModulesC (eff (R (handleCoercible other))) @@ -126,14 +122,12 @@ instance Eq1 (LoadError address value) where instance NFData1 (LoadError address value) where liftRnf _ (ModuleNotFoundError p) = rnf p -runLoadError :: (Carrier sig m, Effect sig) - => Evaluator term address value (ResumableC (BaseError (LoadError address value)) (Eff m)) a +runLoadError :: Evaluator term address value (ResumableC (BaseError (LoadError address value)) m) a -> Evaluator term address value m (Either (SomeError (BaseError (LoadError address value))) a) runLoadError = raiseHandler runResumable -runLoadErrorWith :: Carrier sig m - => (forall resume . (BaseError (LoadError address value)) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) (Eff m)) a +runLoadErrorWith :: (forall resume . (BaseError (LoadError address value)) resume -> Evaluator term address value m resume) + -> Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) m) a -> Evaluator term address value m a runLoadErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) @@ -164,14 +158,12 @@ instance NFData1 ResolutionError where NotFoundError p ps l -> rnf p `seq` rnf ps `seq` rnf l GoImportError p -> rnf p -runResolutionError :: (Carrier sig m, Effect sig) - => Evaluator term address value (ResumableC (BaseError ResolutionError) (Eff m)) a +runResolutionError :: Evaluator term address value (ResumableC (BaseError ResolutionError) m) a -> Evaluator term address value m (Either (SomeError (BaseError ResolutionError)) a) runResolutionError = raiseHandler runResumable -runResolutionErrorWith :: Carrier sig m - => (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff m)) a +runResolutionErrorWith :: (forall resume . (BaseError ResolutionError) resume -> Evaluator term address value m resume) + -> Evaluator term address value (ResumableWithC (BaseError ResolutionError) m) a -> Evaluator term address value m a runResolutionErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 268722098..937248db1 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -355,7 +355,7 @@ instance NFData return => NFData (ScopeError address return) where rnf = liftRnf rnf alloc :: (Member (Allocator address) sig, Carrier sig m) => Name -> Evaluator term address value m address -alloc = send . flip Alloc ret +alloc = send . flip Alloc pure data Allocator address (m :: * -> *) k = Alloc Name (address -> k) @@ -367,21 +367,18 @@ instance HFunctor (Allocator address) where instance Effect (Allocator address) where handle state handler (Alloc name k) = Alloc name (handler . (<$ state) . k) -runAllocator :: Carrier (Allocator address :+: sig) (AllocatorC address m) - => Evaluator term address value (AllocatorC address m) a +runAllocator :: Evaluator term address value (AllocatorC address m) a -> Evaluator term address value m a runAllocator = raiseHandler runAllocatorC newtype AllocatorC address m a = AllocatorC { runAllocatorC :: m a } deriving (Alternative, Applicative, Functor, Monad) -runScopeErrorWith :: Carrier sig m - => (forall resume . BaseError (ScopeError address) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) (Eff m)) a +runScopeErrorWith :: (forall resume . BaseError (ScopeError address) resume -> Evaluator term address value m resume) + -> Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) m) a -> Evaluator term address value m a runScopeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) -runScopeError :: (Carrier sig m, Effect sig) - => Evaluator term address value (ResumableC (BaseError (ScopeError address)) m) a +runScopeError :: Evaluator term address value (ResumableC (BaseError (ScopeError address)) m) a -> Evaluator term address value m (Either (SomeError (BaseError (ScopeError address))) a) runScopeError = raiseHandler runResumable diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 31c429fb2..fbd064d3c 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, GADTs, KindSignatures, LambdaCase, Rank2Types, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE DeriveAnyClass, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, Rank2Types, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Value ( AbstractValue(..) , AbstractIntro(..) @@ -105,7 +105,7 @@ data Comparator -- In the concrete domain, introductions & eliminations respectively construct & pattern match against values, while in abstract domains they respectively construct & project finite sets of discrete observations of abstract values. For example, an abstract domain modelling integers as a sign (-, 0, or +) would introduce abstract values by mapping integers to their sign and eliminate them by mapping signs back to some canonical integer, e.g. - -> -1, 0 -> 0, + -> 1. function :: (Member (Function term address value) sig, Carrier sig m) => Name -> [Name] -> term -> address -> Evaluator term address value m value -function name params body scope = sendFunction (Function name params body scope ret) +function name params body scope = sendFunction (Function name params body scope pure) data BuiltIn = Print @@ -113,16 +113,16 @@ data BuiltIn deriving (Eq, Ord, Show, Generic, NFData) builtIn :: (Member (Function term address value) sig, Carrier sig m) => address -> BuiltIn -> Evaluator term address value m value -builtIn address = sendFunction . flip (BuiltIn address) ret +builtIn address = sendFunction . flip (BuiltIn address) pure call :: (Member (Function term address value) sig, Carrier sig m) => value -> [value] -> Evaluator term address value m value -call fn args = sendFunction (Call fn args ret) +call fn args = sendFunction (Call fn args pure) sendFunction :: (Member (Function term address value) sig, Carrier sig m) => Function term address value (Evaluator term address value m) (Evaluator term address value m a) -> Evaluator term address value m a sendFunction = send bindThis :: (Member (Function term address value) sig, Carrier sig m) => value -> value -> Evaluator term address value m value -bindThis this that = sendFunction (Bind this that ret) +bindThis this that = sendFunction (Bind this that pure) data Function term address value (m :: * -> *) k = Function Name [Name] term address (value -> k) -- ^ A function is parameterized by its name, parameter names, body, parent scope, and returns a ValueRef. @@ -138,22 +138,21 @@ instance Effect (Function term address value) where handle state handler = coerce . fmap (handler . (<$ state)) -runFunction :: Carrier (Function term address value :+: sig) (FunctionC term address value (Eff m)) - => (term -> Evaluator term address value (FunctionC term address value (Eff m)) value) - -> Evaluator term address value (FunctionC term address value (Eff m)) a +runFunction :: (term -> Evaluator term address value (FunctionC term address value m) value) + -> Evaluator term address value (FunctionC term address value m) a -> Evaluator term address value m a -runFunction eval = raiseHandler (flip runFunctionC (runEvaluator . eval) . interpret) - -newtype FunctionC term address value m a = FunctionC { runFunctionC :: (term -> Eff (FunctionC term address value m) value) -> m a } +runFunction eval = raiseHandler (runReader eval . coerce) +newtype FunctionC term address value m a = FunctionC { runFunctionC :: ReaderC (term -> FunctionC term address value m value) m a } + deriving (Applicative, Functor, Monad) -- | Construct a boolean value in the abstract domain. boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value -boolean = send . flip Boolean ret +boolean = send . flip Boolean pure -- | Extract a 'Bool' from a given value. asBool :: (Member (Boolean value) sig, Carrier sig m) => value -> m Bool -asBool = send . flip AsBool ret +asBool = send . flip AsBool pure -- | Eliminate boolean values. TODO: s/boolean/truthy ifthenelse :: (Member (Boolean value) sig, Carrier sig m) => value -> m a -> m a -> m a @@ -173,10 +172,10 @@ instance Effect (Boolean value) where Boolean b k -> Boolean b (handler . (<$ state) . k) AsBool v k -> AsBool v (handler . (<$ state) . k) -runBoolean :: Carrier (Boolean value :+: sig) (BooleanC value (Eff m)) - => Evaluator term address value (BooleanC value (Eff m)) a +runBoolean :: Carrier (Boolean value :+: sig) (BooleanC value m) + => Evaluator term address value (BooleanC value m) a -> Evaluator term address value m a -runBoolean = raiseHandler $ runBooleanC . interpret +runBoolean = raiseHandler $ runBooleanC newtype BooleanC value m a = BooleanC { runBooleanC :: m a } @@ -186,7 +185,7 @@ while :: (Member (While value) sig, Carrier sig m) => Evaluator term address value m value -- ^ Condition -> Evaluator term address value m value -- ^ Body -> Evaluator term address value m value -while cond body = send (While cond body ret) +while cond body = send (While cond body pure) -- | Do-while loop, built on top of while. doWhile :: (Member (While value) sig, Carrier sig m) @@ -223,17 +222,17 @@ data While value m k instance HFunctor (While value) where hmap f (While cond body k) = While (f cond) (f body) k -runWhile :: Carrier (While value :+: sig) (WhileC value (Eff m)) - => Evaluator term address value (WhileC value (Eff m)) a +runWhile :: Carrier (While value :+: sig) (WhileC value m) + => Evaluator term address value (WhileC value m) a -> Evaluator term address value m a -runWhile = raiseHandler $ runWhileC . interpret +runWhile = raiseHandler $ runWhileC newtype WhileC value m a = WhileC { runWhileC :: m a } -- | Construct an abstract unit value. unit :: (Carrier sig m, Member (Unit value) sig) => Evaluator term address value m value -unit = send (Unit ret) +unit = send (Unit pure) newtype Unit value (m :: * -> *) k = Unit (value -> k) @@ -246,21 +245,21 @@ instance HFunctor (Unit value) where instance Effect (Unit value) where handle state handler (Unit k) = Unit (handler . (<$ state) . k) -runUnit :: Carrier (Unit value :+: sig) (UnitC value (Eff m)) - => Evaluator term address value (UnitC value (Eff m)) a +runUnit :: Carrier (Unit value :+: sig) (UnitC value m) + => Evaluator term address value (UnitC value m) a -> Evaluator term address value m a -runUnit = raiseHandler $ runUnitC . interpret +runUnit = raiseHandler $ runUnitC newtype UnitC value m a = UnitC { runUnitC :: m a } -- | Construct a String value in the abstract domain. string :: (Member (String value) sig, Carrier sig m) => Text -> m value -string t = send (String t ret) +string t = send (String t pure) -- | Extract 'Text' from a given value. asString :: (Member (String value) sig, Carrier sig m) => value -> m Text -asString v = send (AsString v ret) +asString v = send (AsString v pure) data String value (m :: * -> *) k = String Text (value -> k) @@ -277,30 +276,30 @@ instance Effect (String value) where newtype StringC value m a = StringC { runStringC :: m a } -runString :: Carrier (String value :+: sig) (StringC value (Eff m)) - => Evaluator term address value (StringC value (Eff m)) a +runString :: Carrier (String value :+: sig) (StringC value m) + => Evaluator term address value (StringC value m) a -> Evaluator term address value m a -runString = raiseHandler $ runStringC . interpret +runString = raiseHandler $ runStringC -- | Construct an abstract integral value. integer :: (Member (Numeric value) sig, Carrier sig m) => Integer -> m value -integer t = send (Integer t ret) +integer t = send (Integer t pure) -- | Construct a floating-point value. float :: (Member (Numeric value) sig, Carrier sig m) => Scientific -> m value -float t = send (Float t ret) +float t = send (Float t pure) -- | Construct a rational value. rational :: (Member (Numeric value) sig, Carrier sig m) => Rational -> m value -rational t = send (Rational t ret) +rational t = send (Rational t pure) -- | Lift a unary operator over a 'Num' to a function on 'value's. liftNumeric :: (Member (Numeric value) sig, Carrier sig m) => (forall a . Num a => a -> a) -> value -> m value -liftNumeric t v = send (LiftNumeric t v ret) +liftNumeric t v = send (LiftNumeric t v pure) -- | Lift a pair of binary operators to a function on 'value's. -- You usually pass the same operator as both arguments, except in the cases where @@ -311,7 +310,7 @@ liftNumeric2 :: (Member (Numeric value) sig, Carrier sig m) -> value -> value -> m value -liftNumeric2 t v1 v2 = send (LiftNumeric2 t v1 v2 ret) +liftNumeric2 t v1 v2 = send (LiftNumeric2 t v1 v2 pure) data Numeric value (m :: * -> *) k = Integer Integer (value -> k) @@ -330,22 +329,22 @@ instance Effect (Numeric value) where newtype NumericC value m a = NumericC { runNumericC :: m a } -runNumeric :: Carrier (Numeric value :+: sig) (NumericC value (Eff m)) - => Evaluator term address value (NumericC value (Eff m)) a +runNumeric :: Carrier (Numeric value :+: sig) (NumericC value m) + => Evaluator term address value (NumericC value m) a -> Evaluator term address value m a -runNumeric = raiseHandler $ runNumericC . interpret +runNumeric = raiseHandler $ runNumericC -- | Cast numbers to integers castToInteger :: (Member (Bitwise value) sig, Carrier sig m) => value -> m value -castToInteger t = send (CastToInteger t ret) +castToInteger t = send (CastToInteger t pure) -- | Lift a unary bitwise operator to values. This is usually 'complement'. liftBitwise :: (Member (Bitwise value) sig, Carrier sig m) => (forall a . Bits a => a -> a) -> value -> m value -liftBitwise t v = send (LiftBitwise t v ret) +liftBitwise t v = send (LiftBitwise t v pure) -- | Lift a binary bitwise operator to values. The Integral constraint is -- necessary to satisfy implementation details of Haskell left/right shift, @@ -355,13 +354,13 @@ liftBitwise2 :: (Member (Bitwise value) sig, Carrier sig m) -> value -> value -> m value -liftBitwise2 t v1 v2 = send (LiftBitwise2 t v1 v2 ret) +liftBitwise2 t v1 v2 = send (LiftBitwise2 t v1 v2 pure) unsignedRShift :: (Member (Bitwise value) sig, Carrier sig m) => value -> value -> m value -unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 ret) +unsignedRShift v1 v2 = send (UnsignedRShift v1 v2 pure) data Bitwise value (m :: * -> *) k = CastToInteger value (value -> k) @@ -377,26 +376,26 @@ instance HFunctor (Bitwise value) where instance Effect (Bitwise value) where handle state handler = coerce . fmap (handler . (<$ state)) -runBitwise :: Carrier (Bitwise value :+: sig) (BitwiseC value (Eff m)) - => Evaluator term address value (BitwiseC value (Eff m)) a +runBitwise :: Carrier (Bitwise value :+: sig) (BitwiseC value m) + => Evaluator term address value (BitwiseC value m) a -> Evaluator term address value m a -runBitwise = raiseHandler $ runBitwiseC . interpret +runBitwise = raiseHandler $ runBitwiseC newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } object :: (Member (Object address value) sig, Carrier sig m) => address -> m value -object address = send (Object address ret) +object address = send (Object address pure) -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). scopedEnvironment :: (Member (Object address value) sig, Carrier sig m) => value -> m (Maybe address) -scopedEnvironment value = send (ScopedEnvironment value ret) +scopedEnvironment value = send (ScopedEnvironment value pure) -- | Build a class value from a name and environment. -- declaration is the new class's identifier -- address is the environment to capture klass :: (Member (Object address value) sig, Carrier sig m) => Declaration -> address -> m value -klass d a = send (Klass d a ret) +klass d a = send (Klass d a pure) data Object address value (m :: * -> *) k = Object address (value -> k) @@ -413,17 +412,17 @@ instance Effect (Object address value) where newtype ObjectC address value m a = ObjectC { runObjectC :: m a } -runObject :: Carrier (Object address value :+: sig) (ObjectC address value (Eff m)) - => Evaluator term address value (ObjectC address value (Eff m)) a +runObject :: Carrier (Object address value :+: sig) (ObjectC address value m) + => Evaluator term address value (ObjectC address value m) a -> Evaluator term address value m a -runObject = raiseHandler $ runObjectC . interpret +runObject = raiseHandler $ runObjectC -- | Construct an array of zero or more values. array :: (Member (Array value) sig, Carrier sig m) => [value] -> m value -array v = send (Array v ret) +array v = send (Array v pure) asArray :: (Member (Array value) sig, Carrier sig m) => value -> m [value] -asArray v = send (AsArray v ret) +asArray v = send (AsArray v pure) data Array value (m :: * -> *) k = Array [value] (value -> k) @@ -439,18 +438,18 @@ instance Effect (Array value) where newtype ArrayC value m a = ArrayC { runArrayC :: m a } -runArray :: Carrier (Array value :+: sig) (ArrayC value (Eff m)) - => Evaluator term address value (ArrayC value (Eff m)) a +runArray :: Carrier (Array value :+: sig) (ArrayC value m) + => Evaluator term address value (ArrayC value m) a -> Evaluator term address value m a -runArray = raiseHandler $ runArrayC . interpret +runArray = raiseHandler $ runArrayC -- | Construct a hash out of pairs. hash :: (Member (Hash value) sig, Carrier sig m) => [(value, value)] -> m value -hash v = send (Hash v ret) +hash v = send (Hash v pure) -- | Construct a key-value pair for use in a hash. kvPair :: (Member (Hash value) sig, Carrier sig m) => value -> value -> m value -kvPair v1 v2 = send (KvPair v1 v2 ret) +kvPair v1 v2 = send (KvPair v1 v2 pure) data Hash value (m :: * -> *) k = Hash [(value, value)] (value -> k) @@ -466,10 +465,10 @@ instance Effect (Hash value) where newtype HashC value m a = HashC { runHashC :: m a } -runHash :: Carrier (Hash value :+: sig) (HashC value (Eff m)) - => Evaluator term address value (HashC value (Eff m)) a +runHash :: Carrier (Hash value :+: sig) (HashC value m) + => Evaluator term address value (HashC value m) a -> Evaluator term address value m a -runHash = raiseHandler $ runHashC . interpret +runHash = raiseHandler $ runHashC class Show value => AbstractIntro value where -- | Construct the nil/null datatype. diff --git a/src/Control/Effect/Interpose.hs b/src/Control/Effect/Interpose.hs index b6e0a5efe..b3bd092cb 100644 --- a/src/Control/Effect/Interpose.hs +++ b/src/Control/Effect/Interpose.hs @@ -36,17 +36,19 @@ interpose m f = send (Interpose m f pure) runInterpose :: InterposeC eff m a -> m a runInterpose = runReader Nothing . runInterposeC -newtype InterposeC eff m a = InterposeC { runInterposeC :: ReaderC (Maybe (Listener eff m)) m a } +newtype InterposeC eff m a = InterposeC { runInterposeC :: ReaderC (Maybe (Listener eff (InterposeC eff m))) m a } deriving (Alternative, Applicative, Functor, Monad) newtype Listener eff m = Listener (forall n x . eff n (n x) -> m x) -runListener :: Listener eff m -> eff (InterposeC eff m) (InterposeC eff m a) -> InterposeC eff m a -runListener l@(Listener listen) = undefined --listen . runReader (Just l) . runInterposeC +-- TODO: Document the implementation of this, as it is extremely subtle. + +runListener :: Listener eff (InterposeC eff m) -> eff (InterposeC eff m) (InterposeC eff m a) -> InterposeC eff m a +runListener (Listener listen) = listen instance (Carrier sig m, Member eff sig) => Carrier (Interpose eff :+: sig) (InterposeC eff m) where eff (L (Interpose m h k)) = - local (const _) m >>= k + InterposeC (local (const (Just (Listener h))) (runInterposeC m)) >>= k eff (R other) = do listener <- InterposeC ask case (listener, prj other) of diff --git a/src/Control/Effect/REPL.hs b/src/Control/Effect/REPL.hs index 329ae2825..7be7c350a 100644 --- a/src/Control/Effect/REPL.hs +++ b/src/Control/Effect/REPL.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-} module Control.Effect.REPL ( REPL (..) @@ -13,6 +13,7 @@ import Prologue import Control.Effect import Control.Effect.Carrier import Control.Effect.Sum +import Control.Effect.Reader import System.Console.Haskeline import qualified Data.Text as T @@ -29,20 +30,24 @@ instance Effect REPL where handle state handler (Output s k) = Output s (handler (k <$ state)) prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text) -prompt p = send (Prompt p ret) +prompt p = send (Prompt p pure) output :: (Member REPL sig, Carrier sig m) => Text -> m () -output s = send (Output s (ret ())) +output s = send (Output s (pure ())) -runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> REPLC m a -> m a -runREPL prefs settings = flip runREPLC (prefs, settings) . interpret +runREPL :: Prefs -> Settings IO -> REPLC m a -> m a +runREPL prefs settings = runReader (prefs, settings) . runREPLC -newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a } +newtype REPLC m a = REPLC { runREPLC :: ReaderC (Prefs, Settings IO) m a } + deriving (Functor, Applicative, Monad, MonadIO) instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where - eff (L (Prompt p k)) = REPLC (liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= k) - eff (L (Output s k)) = REPLC (liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> k) - eff (R other) = REPLC (eff (handleCoercible other)) + eff (L op) = do + args <- REPLC ask + case op of + Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= k + Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> k + eff (R other) = REPLC (eff (R (handleCoercible other))) cyan :: String diff --git a/src/Diffing/Algorithm.hs b/src/Diffing/Algorithm.hs index 9b83a2168..f950bc8c4 100644 --- a/src/Diffing/Algorithm.hs +++ b/src/Diffing/Algorithm.hs @@ -48,19 +48,17 @@ instance Effect (Diff term1 term2 diff) where newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: m a } - deriving (Applicative, Functor, Monad) - -deriving instance (Carrier sig m, Member NonDet sig) => Alternative (Algorithm term1 term2 diff m) + deriving (Applicative, Alternative, Functor, Monad) instance Carrier sig m => Carrier sig (Algorithm term1 term2 diff m) where - eff = Algorithm . eff + eff = Algorithm . eff . handleCoercible -- DSL -- | Diff two terms without specifying the algorithm to be used. diff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> m diff -diff a1 a2 = send (Diff a1 a2 ret) +diff a1 a2 = send (Diff a1 a2 pure) -- | Diff a These of terms without specifying the algorithm to be used. diffThese :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => These term1 term2 -> Algorithm term1 term2 diff m diff @@ -75,30 +73,30 @@ diffMaybe _ _ = pure Nothing -- | Diff two terms linearly. linearly :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff -linearly f1 f2 = send (Linear f1 f2 ret) +linearly f1 f2 = send (Linear f1 f2 pure) -- | Diff two terms using RWS. byRWS :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => [term1] -> [term2] -> Algorithm term1 term2 diff m [diff] -byRWS as1 as2 = send (RWS as1 as2 ret) +byRWS as1 as2 = send (RWS as1 as2 pure) -- | Delete a term. byDeleting :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> Algorithm term1 term2 diff m diff -byDeleting a1 = sendDiff (Delete a1 ret) +byDeleting a1 = sendDiff (Delete a1 pure) -- | Insert a term. byInserting :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term2 -> Algorithm term1 term2 diff m diff -byInserting a2 = sendDiff (Insert a2 ret) +byInserting a2 = sendDiff (Insert a2 pure) -- | Replace one term with another. byReplacing :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff -byReplacing a1 a2 = send (Replace a1 a2 ret) +byReplacing a1 a2 = send (Replace a1 a2 pure) -sendDiff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Diff term1 term2 diff (Eff m) (Eff m a) -> Algorithm term1 term2 diff m a +sendDiff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Diff term1 term2 diff m (m a) -> Algorithm term1 term2 diff m a sendDiff = Algorithm . send -- | Diff two terms based on their 'Diffable' instances, performing substructural comparisons iff the initial comparison fails. -algorithmForTerms :: (Carrier sig m, Diffable syntax, Member (Diff (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2)) sig, Member NonDet sig) +algorithmForTerms :: (Carrier sig m, Diffable syntax, Member (Diff (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2)) sig, Member NonDet sig, Alternative m) => Term syntax ann1 -> Term syntax ann2 -> Algorithm (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2) m (Diff.Diff syntax ann1 ann2) @@ -141,12 +139,12 @@ instance Alternative Equivalence where -- | A type class for determining what algorithm to use for diffing two terms. class Diffable f where -- | Construct an algorithm to diff a pair of @f@s populated with disjoint terms. - algorithmFor :: (Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) + algorithmFor :: (Alternative m, Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) default - algorithmFor :: (Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig) + algorithmFor :: (Alternative m, Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) @@ -189,7 +187,7 @@ class Diffable f where default comparableTo :: (Generic1 f, GDiffable (Rep1 f)) => f term1 -> f term2 -> Bool comparableTo = genericComparableTo -genericAlgorithmFor :: (Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig) +genericAlgorithmFor :: (Alternative m, Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) @@ -237,7 +235,7 @@ instance Diffable NonEmpty where -- | A generic type class for diffing two terms defined by the Generic1 interface. class GDiffable f where - galgorithmFor :: (Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) + galgorithmFor :: (Alternative m, Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff) gtryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 4bf13612f..1d5e3516c 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-} module Diffing.Interpreter ( diffTerms , diffTermPair @@ -7,6 +7,7 @@ module Diffing.Interpreter import Control.Effect import Control.Effect.Carrier +import Control.Effect.Cull import Control.Effect.NonDet import Control.Effect.Sum import qualified Data.Diff as Diff @@ -44,10 +45,11 @@ runDiff :: (Alternative m, Carrier sig m, Diffable syntax, Eq1 syntax, Member No (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m) result -> m result -runDiff = runDiffC . interpret . runAlgorithm +runDiff = runDiffC . runAlgorithm newtype DiffC term1 term2 diff m a = DiffC { runDiffC :: m a } + deriving (Alternative, Applicative, Functor, Monad, MonadIO) instance ( Alternative m , Carrier sig m @@ -60,11 +62,11 @@ instance ( Alternative m => Carrier (Diff (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) :+: sig) (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m) where - ret = DiffC . ret - eff = DiffC . handleSum (eff . handleCoercible) (\case - Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= runDiffC . k - Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= runDiffC . k - RWS as bs k -> traverse (runDiff . diffThese) (rws comparableTerms equivalentTerms as bs) >>= runDiffC . k - Delete a k -> runDiffC (k (Diff.deleting a)) - Insert b k -> runDiffC (k (Diff.inserting b)) - Replace a b k -> runDiffC (k (Diff.replacing a b))) + eff (L op) = case op of + Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= k + Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= k + RWS as bs k -> traverse (runDiff . diffThese) (rws comparableTerms equivalentTerms as bs) >>= k + Delete a k -> k (Diff.deleting a) + Insert b k -> k (Diff.inserting b) + Replace a b k -> k (Diff.replacing a b) + eff (R other) = DiffC . eff . handleCoercible $ other diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 2caad9d5a..43479ea5d 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -27,9 +27,9 @@ import qualified Data.Text as T renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex renderTreeGraph = simplify . runGraph . cata toTreeGraph -runGraph :: Eff (ReaderC (Graph vertex) - (Eff (FreshC - (Eff VoidC)))) (Graph vertex) +runGraph :: ReaderC (Graph vertex) + (FreshC + (VoidC)) (Graph vertex) -> Graph vertex runGraph = run . runFresh . runReader mempty diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index d147eb81b..a3b52d484 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DerivingStrategies, GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-} module Semantic.Telemetry ( -- Async telemetry interface @@ -154,18 +154,16 @@ instance Effect Telemetry where runTelemetry :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> TelemetryC m a -> m a runTelemetry logger statter = flip runTelemetryC (logger, statter) -newtype TelemetryC m a = TelemetryC { runTelemetryC :: (LogQueue, StatQueue) -> m a } - deriving stock Functor - deriving (Applicative, Monad) via (ReaderC (LogQueue, StatQueue)) +newtype TelemetryC m a = TelemetryC { runTelemetryC :: ReaderC (LogQueue, StatQueue) m a } + deriving (Applicative, Functor, Monad, MonadIO) instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m) where - eff (L op) = TelemetryC (\ queues -> case op of - WriteStat stat k -> queueStat (snd queues) stat *> runTelemetryC k queues - WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> runTelemetryC k queues) - eff (R other) = TelemetryC (\queues -> eff (handlePure (flip runTelemetryC queues) other)) - - - + eff (L op) = do + queues <- TelemetryC ask + case op of + WriteStat stat k -> queueStat (snd queues) stat *> k + WriteLog level message pairs k -> queueLogMessage (fst queues) level message pairs *> k + eff (R other) = TelemetryC (eff (R (handleCoercible other))) -- | Run a 'Telemetry' effect by ignoring statting/logging. ignoreTelemetry :: Carrier sig m => Eff (IgnoreTelemetryC m) a -> m a diff --git a/src/Semantic/Timeout.hs b/src/Semantic/Timeout.hs index 3a91f097b..7e5f371e1 100644 --- a/src/Semantic/Timeout.hs +++ b/src/Semantic/Timeout.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, TypeOperators, RankNTypes, UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, TypeOperators, RankNTypes, UndecidableInstances #-} module Semantic.Timeout ( timeout , Timeout From 43bbcb01a590798ea8abbb9afce9049239df6977 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Mar 2019 17:35:01 -0500 Subject: [PATCH 19/32] WIP --- .../Abstract/Caching/FlowInsensitive.hs | 10 +- .../Abstract/Caching/FlowSensitive.hs | 2 +- src/Analysis/Abstract/Collecting.hs | 2 +- src/Control/Abstract/Value.hs | 62 +++--- src/Data/Abstract/Address/Hole.hs | 2 - src/Data/Abstract/Address/Monovariant.hs | 14 +- src/Data/Abstract/Address/Precise.hs | 2 - src/Data/Abstract/Evaluatable.hs | 17 +- src/Data/Abstract/Value/Abstract.hs | 51 +++-- src/Data/Abstract/Value/Concrete.hs | 183 +++++++++--------- src/Data/Abstract/Value/Type.hs | 173 ++++++++--------- src/Semantic/Analysis.hs | 40 ++-- src/Semantic/Distribute.hs | 4 +- src/Tags/Tagging.hs | 6 +- 14 files changed, 276 insertions(+), 292 deletions(-) diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs index 210ab720b..aae78df92 100644 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -85,7 +85,7 @@ convergingModules :: ( Eq value , Carrier sig m , Effect sig ) - => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) value) + => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe m) value) -> (Module (Either prelude term) -> Evaluator term address value m value) convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty convergingModules recur m@(Module _ (Right term)) = do @@ -130,10 +130,10 @@ getConfiguration term = Configuration term <$> askRoots caching :: (Carrier sig m, Effect sig) - => Evaluator term address value (AltC B (Eff - (ReaderC (Cache term address value) (Eff - (StateC (Cache term address value) (Eff - m)))))) a + => Evaluator term address value (AltC B + (ReaderC (Cache term address value) + (StateC (Cache term address value) + m))) a -> Evaluator term address value m (Cache term address value, [a]) caching = raiseHandler (runState lowerBound) diff --git a/src/Analysis/Abstract/Caching/FlowSensitive.hs b/src/Analysis/Abstract/Caching/FlowSensitive.hs index 8a5e48b44..41359bcac 100644 --- a/src/Analysis/Abstract/Caching/FlowSensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowSensitive.hs @@ -83,7 +83,7 @@ convergingModules :: ( Cacheable term address value , Carrier sig m , Effect sig ) - => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe (Eff m)) value) + => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe m) value) -> (Module (Either prelude term) -> Evaluator term address value m value) convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty convergingModules recur m@(Module _ (Right term)) = do diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 72f72d58b..b811c78df 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -5,5 +5,5 @@ module Analysis.Abstract.Collecting import Control.Abstract import Prologue -providingLiveSet :: Carrier sig m => Evaluator term address value (ReaderC (Live address) (Eff m)) a -> Evaluator term address value m a +providingLiveSet :: Carrier sig m => Evaluator term address value (ReaderC (Live address) m) a -> Evaluator term address value m a providingLiveSet = raiseHandler (runReader lowerBound) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index fbd064d3c..d4b088c52 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, Rank2Types, ScopedTypeVariables, TypeOperators #-} +{-# LANGUAGE DeriveAnyClass, DerivingStrategies, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, Rank2Types, ScopedTypeVariables, TypeOperators #-} module Control.Abstract.Value ( AbstractValue(..) , AbstractIntro(..) @@ -141,10 +141,10 @@ instance Effect (Function term address value) where runFunction :: (term -> Evaluator term address value (FunctionC term address value m) value) -> Evaluator term address value (FunctionC term address value m) a -> Evaluator term address value m a -runFunction eval = raiseHandler (runReader eval . coerce) +runFunction eval = raiseHandler (runReader (runEvaluator . eval) . runFunctionC) newtype FunctionC term address value m a = FunctionC { runFunctionC :: ReaderC (term -> FunctionC term address value m value) m a } - deriving (Applicative, Functor, Monad) + deriving newtype (Applicative, Functor, Monad) -- | Construct a boolean value in the abstract domain. boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value @@ -172,12 +172,13 @@ instance Effect (Boolean value) where Boolean b k -> Boolean b (handler . (<$ state) . k) AsBool v k -> AsBool v (handler . (<$ state) . k) -runBoolean :: Carrier (Boolean value :+: sig) (BooleanC value m) - => Evaluator term address value (BooleanC value m) a +runBoolean :: Evaluator term address value (BooleanC value m) a -> Evaluator term address value m a runBoolean = raiseHandler $ runBooleanC newtype BooleanC value m a = BooleanC { runBooleanC :: m a } + deriving stock Functor + deriving newtype (Alternative, Applicative, Monad) -- | The fundamental looping primitive, built on top of 'ifthenelse'. @@ -222,13 +223,13 @@ data While value m k instance HFunctor (While value) where hmap f (While cond body k) = While (f cond) (f body) k -runWhile :: Carrier (While value :+: sig) (WhileC value m) - => Evaluator term address value (WhileC value m) a +runWhile :: Evaluator term address value (WhileC value m) a -> Evaluator term address value m a runWhile = raiseHandler $ runWhileC newtype WhileC value m a = WhileC { runWhileC :: m a } - + deriving stock Functor + deriving newtype (Alternative, Applicative, Monad) -- | Construct an abstract unit value. unit :: (Carrier sig m, Member (Unit value) sig) => Evaluator term address value m value @@ -236,7 +237,7 @@ unit = send (Unit pure) newtype Unit value (m :: * -> *) k = Unit (value -> k) - deriving (Functor) + deriving stock Functor instance HFunctor (Unit value) where hmap _ = coerce @@ -245,13 +246,13 @@ instance HFunctor (Unit value) where instance Effect (Unit value) where handle state handler (Unit k) = Unit (handler . (<$ state) . k) -runUnit :: Carrier (Unit value :+: sig) (UnitC value m) - => Evaluator term address value (UnitC value m) a +runUnit :: Evaluator term address value (UnitC value m) a -> Evaluator term address value m a runUnit = raiseHandler $ runUnitC newtype UnitC value m a = UnitC { runUnitC :: m a } - + deriving stock Functor + deriving newtype (Applicative, Monad) -- | Construct a String value in the abstract domain. string :: (Member (String value) sig, Carrier sig m) => Text -> m value @@ -275,9 +276,10 @@ instance Effect (String value) where handle state handler (AsString v k) = AsString v (handler . (<$ state) . k) newtype StringC value m a = StringC { runStringC :: m a } + deriving stock Functor + deriving newtype (Applicative, Monad) -runString :: Carrier (String value :+: sig) (StringC value m) - => Evaluator term address value (StringC value m) a +runString :: Evaluator term address value (StringC value m) a -> Evaluator term address value m a runString = raiseHandler $ runStringC @@ -328,9 +330,10 @@ instance Effect (Numeric value) where handle state handler = coerce . fmap (handler . (<$ state)) newtype NumericC value m a = NumericC { runNumericC :: m a } + deriving stock Functor + deriving newtype (Applicative, Monad) -runNumeric :: Carrier (Numeric value :+: sig) (NumericC value m) - => Evaluator term address value (NumericC value m) a +runNumeric :: Evaluator term address value (NumericC value m) a -> Evaluator term address value m a runNumeric = raiseHandler $ runNumericC @@ -376,13 +379,13 @@ instance HFunctor (Bitwise value) where instance Effect (Bitwise value) where handle state handler = coerce . fmap (handler . (<$ state)) -runBitwise :: Carrier (Bitwise value :+: sig) (BitwiseC value m) - => Evaluator term address value (BitwiseC value m) a +runBitwise :: Evaluator term address value (BitwiseC value m) a -> Evaluator term address value m a runBitwise = raiseHandler $ runBitwiseC newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } - + deriving stock Functor + deriving newtype (Applicative, Monad) object :: (Member (Object address value) sig, Carrier sig m) => address -> m value object address = send (Object address pure) @@ -411,10 +414,11 @@ instance Effect (Object address value) where handle state handler = coerce . fmap (handler . (<$ state)) newtype ObjectC address value m a = ObjectC { runObjectC :: m a } + deriving stock Functor + deriving newtype (Applicative, Monad) -runObject :: Carrier (Object address value :+: sig) (ObjectC address value m) - => Evaluator term address value (ObjectC address value m) a - -> Evaluator term address value m a +runObject :: Evaluator term address value (ObjectC address value m) a + -> Evaluator term address value m a runObject = raiseHandler $ runObjectC -- | Construct an array of zero or more values. @@ -437,10 +441,11 @@ instance Effect (Array value) where handle state handler = coerce . fmap (handler . (<$ state)) newtype ArrayC value m a = ArrayC { runArrayC :: m a } + deriving stock Functor + deriving newtype (Applicative, Monad) -runArray :: Carrier (Array value :+: sig) (ArrayC value m) - => Evaluator term address value (ArrayC value m) a - -> Evaluator term address value m a +runArray :: Evaluator term address value (ArrayC value m) a + -> Evaluator term address value m a runArray = raiseHandler $ runArrayC -- | Construct a hash out of pairs. @@ -464,10 +469,11 @@ instance Effect (Hash value) where handle state handler = coerce . fmap (handler . (<$ state)) newtype HashC value m a = HashC { runHashC :: m a } + deriving stock Functor + deriving newtype (Applicative, Monad) -runHash :: Carrier (Hash value :+: sig) (HashC value m) - => Evaluator term address value (HashC value m) a - -> Evaluator term address value m a +runHash :: Evaluator term address value (HashC value m) a + -> Evaluator term address value m a runHash = raiseHandler $ runHashC class Show value => AbstractIntro value where diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index 84a789e06..651fcdb7a 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -28,7 +28,6 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m) , Monad m ) => Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where - ret = promoteA . ret eff = handleSum (AllocatorC . eff . handleCoercible) (\ (Alloc name k) -> Total <$> promoteA (eff (L (Alloc name ret))) >>= k) @@ -39,7 +38,6 @@ promoteD = DerefC . runDerefC instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m) => Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where - ret = promoteD . ret eff = handleSum (DerefC . eff . handleCoercible) (\case DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k) diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs index bb2a430fa..e26a4b912 100644 --- a/src/Data/Abstract/Address/Monovariant.hs +++ b/src/Data/Abstract/Address/Monovariant.hs @@ -19,14 +19,10 @@ instance Show Monovariant where instance Carrier sig m => Carrier (Allocator Monovariant :+: sig) (AllocatorC Monovariant m) where - ret = AllocatorC . ret - eff = AllocatorC . handleSum - (eff . handleCoercible) - (\ (Alloc name k) -> runAllocatorC (k (Monovariant name))) - + eff (L (Alloc name k)) = k (Monovariant name) + eff (R other) = AllocatorC . eff . handleCoercible $ other instance (Ord value, Carrier sig m, Alternative m, Monad m) => Carrier (Deref value :+: sig) (DerefC Monovariant value m) where - ret = DerefC . ret - eff = DerefC . handleSum (eff . handleCoercible) (\case - DerefCell cell k -> traverse (foldMapA pure) (nonEmpty (toList cell)) >>= runDerefC . k - AssignCell value cell k -> runDerefC (k (Set.insert value cell))) + eff (L (DerefCell cell k)) = traverse (foldMapA pure) (nonEmpty (toList cell)) >>= k + eff (L (AssignCell value cell k)) = k (Set.insert value cell) + eff (R other) = DerefC . eff . handleCoercible $ other diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index 0080f5595..e7c2110e7 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -19,14 +19,12 @@ instance Show Precise where instance (Member Fresh sig, Carrier sig m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where - ret = AllocatorC . ret eff = AllocatorC . handleSum (eff . handleCoercible) (\ (Alloc _ k) -> Precise <$> fresh >>= runAllocatorC . k) instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where - ret = DerefC . ret eff = DerefC . handleSum (eff . handleCoercible) (\case DerefCell cell k -> runDerefC (k (fst <$> Set.minView cell)) AssignCell value _ k -> runDerefC (k (Set.singleton value))) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 1b885754a..5f3d5ee1e 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -30,7 +30,7 @@ import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.Name as X -import qualified Data.Abstract.ScopeGraph as ScopeGraph +import qualified Data.Abstract.ScopeGraph as ScopeGraph import Data.Abstract.ScopeGraph (Relation(..)) import Data.Abstract.AccessControls.Class as X import Data.Language @@ -258,10 +258,13 @@ instance (Eq term, Eq value) => Eq1 (EvalError term address value) where instance (Show term, Show value) => Show1 (EvalError term address value) where liftShowsPrec _ _ = showsPrec -runEvalError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError (EvalError term address value)) (Eff m)) a -> Evaluator term address value m (Either (SomeError (BaseError (EvalError term address value))) a) +runEvalError :: Evaluator term address value (ResumableC (BaseError (EvalError term address value)) m) a + -> Evaluator term address value m (Either (SomeError (BaseError (EvalError term address value))) a) runEvalError = raiseHandler runResumable -runEvalErrorWith :: Carrier sig m => (forall resume . (BaseError (EvalError term address value)) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) (Eff m)) a -> Evaluator term address value m a +runEvalErrorWith :: (forall resume . (BaseError (EvalError term address value)) resume -> Evaluator term address value m resume) + -> Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) m) a + -> Evaluator term address value m a runEvalErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) throwEvalError :: ( Member (Reader ModuleInfo) sig @@ -297,14 +300,12 @@ instance Eq1 (UnspecializedError address value) where instance Show1 (UnspecializedError address value) where liftShowsPrec _ _ = showsPrec -runUnspecialized :: (Carrier sig m, Effect sig) - => Evaluator term address value (ResumableC (BaseError (UnspecializedError address value)) (Eff m)) a +runUnspecialized :: Evaluator term address value (ResumableC (BaseError (UnspecializedError address value)) m) a -> Evaluator term address value m (Either (SomeError (BaseError (UnspecializedError address value))) a) runUnspecialized = raiseHandler runResumable -runUnspecializedWith :: Carrier sig m - => (forall resume . BaseError (UnspecializedError address value) resume -> Evaluator term address value m resume) - -> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) (Eff m)) a +runUnspecializedWith :: (forall resume . BaseError (UnspecializedError address value) resume -> Evaluator term address value m resume) + -> Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) m) a -> Evaluator term address value m a runUnspecializedWith f = raiseHandler $ runResumableWith (runEvaluator . f) diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 77f51ceff..f0228c73e 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -38,30 +38,31 @@ instance ( Member (Allocator address) sig , Show address , Carrier sig m ) - => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract (Eff m)) where - ret = FunctionC . const . ret - eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case - Function _ params body scope k -> runEvaluator $ do - currentScope' <- currentScope - currentFrame' <- currentFrame - let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame') - frame <- newFrame scope frameLinks - res <- withScopeAndFrame frame $ do - for_ params $ \param -> do - slot <- lookupSlot (Declaration param) - assign slot Abstract - catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body))) - Evaluator $ runFunctionC (k res) eval - BuiltIn _ _ k -> runFunctionC (k Abstract) eval - Bind _ _ k -> runFunctionC (k Abstract) eval - Call _ _ k -> runFunctionC (k Abstract) eval) op) + => Carrier (Abstract.Function term address Abstract :+: sig) (FunctionC term address Abstract m) where + eff (R other) = FunctionC . eff . R . handleCoercible $ other + eff (L op) = runEvaluator $ do + eval <- Evaluator . FunctionC $ ask + case op of + Function _ params body scope k -> do + currentScope' <- currentScope + currentFrame' <- currentFrame + let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame') + frame <- newFrame scope frameLinks + res <- withScopeAndFrame frame $ do + for_ params $ \param -> do + slot <- lookupSlot (Declaration param) + assign slot Abstract + catchReturn (Evaluator (eval body)) + Evaluator (k res) + BuiltIn _ _ k -> Evaluator (k Abstract) + Bind _ _ k -> Evaluator (k Abstract) + Call _ _ k -> Evaluator (k Abstract) instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (BooleanC Abstract m) where - ret = BooleanC . ret - eff = BooleanC . handleSum (eff . handleCoercible) (\case - Boolean _ k -> runBooleanC (k Abstract) - AsBool _ k -> runBooleanC (k True) <|> runBooleanC (k False)) + eff (L (Boolean _ k)) = k Abstract + eff (L (AsBool _ k)) = k True <|> k False + eff (R other) = BooleanC . eff . handleCoercible $ other instance ( Member (Abstract.Boolean Abstract) sig @@ -70,7 +71,6 @@ instance ( Member (Abstract.Boolean Abstract) sig , Monad m ) => Carrier (While Abstract :+: sig) (WhileC Abstract m) where - ret = WhileC . ret eff = WhileC . handleSum (eff . handleCoercible) (\ (Abstract.While cond body k) -> do @@ -80,21 +80,18 @@ instance ( Member (Abstract.Boolean Abstract) sig instance Carrier sig m => Carrier (Unit Abstract :+: sig) (UnitC Abstract m) where - ret = UnitC . ret eff = UnitC . handleSum (eff . handleCoercible) (\ (Abstract.Unit k) -> runUnitC (k Abstract)) instance Carrier sig m => Carrier (Abstract.String Abstract :+: sig) (StringC Abstract m) where - ret = StringC . ret eff = StringC . handleSum (eff . handleCoercible) (\case Abstract.String _ k -> runStringC (k Abstract) AsString _ k -> runStringC (k "")) instance Carrier sig m => Carrier (Numeric Abstract :+: sig) (NumericC Abstract m) where - ret = NumericC . ret eff = NumericC . handleSum (eff . handleCoercible) (\case Integer _ k -> runNumericC (k Abstract) Float _ k -> runNumericC (k Abstract) @@ -104,7 +101,6 @@ instance Carrier sig m instance Carrier sig m => Carrier (Bitwise Abstract :+: sig) (BitwiseC Abstract m) where - ret = BitwiseC . ret eff = BitwiseC . handleSum (eff . handleCoercible) (\case CastToInteger _ k -> runBitwiseC (k Abstract) LiftBitwise _ _ k -> runBitwiseC (k Abstract) @@ -113,7 +109,6 @@ instance Carrier sig m instance Carrier sig m => Carrier (Object address Abstract :+: sig) (ObjectC address Abstract m) where - ret = ObjectC . ret eff = ObjectC . handleSum (eff . handleCoercible) (\case Object _ k -> runObjectC (k Abstract) ScopedEnvironment _ k -> runObjectC (k Nothing) @@ -121,14 +116,12 @@ instance Carrier sig m instance Carrier sig m => Carrier (Array Abstract :+: sig) (ArrayC Abstract m) where - ret = ArrayC . ret eff = ArrayC . handleSum (eff . handleCoercible) (\case Array _ k -> runArrayC (k Abstract) AsArray _ k -> runArrayC (k [])) instance Carrier sig m => Carrier (Hash Abstract :+: sig) (HashC Abstract m) where - ret = HashC . ret eff = HashC . handleSum (eff . handleCoercible) (\case Hash _ k -> runHashC (k Abstract) KvPair _ _ k -> runHashC (k Abstract)) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 800420560..39ed9a82c 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -77,47 +77,48 @@ instance ( FreeVariables term , Show address , Show term ) - => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) (Eff m)) where - ret = FunctionC . const . ret - eff op = + => Carrier (Abstract.Function term address (Value term address) :+: sig) (Abstract.FunctionC term address (Value term address) m) where + eff (R other) = FunctionC . eff . R . handleCoercible $ other + eff (L op) = runEvaluator $ do + eval <- Evaluator . FunctionC $ ask let closure maybeName params body scope = do packageInfo <- currentPackage moduleInfo <- currentModule Closure packageInfo moduleInfo maybeName Nothing params body scope <$> currentFrame - in FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case - Abstract.Function name params body scope k -> runEvaluator $ do - val <- closure (Just name) params (Right body) scope - Evaluator $ runFunctionC (k val) eval - Abstract.BuiltIn associatedScope builtIn k -> runEvaluator $ do - val <- closure Nothing [] (Left builtIn) associatedScope - Evaluator $ runFunctionC (k val) eval - Abstract.Bind obj@Object{} (Closure packageInfo moduleInfo name _ names body scope parentFrame) k -> - runFunctionC (k (Closure packageInfo moduleInfo name (Just obj) names body scope parentFrame)) eval - Abstract.Bind _ value k -> runFunctionC (k value) eval - Abstract.Call op params k -> runEvaluator $ do - boxed <- case op of - Closure _ _ _ _ _ (Left Print) _ _ -> traverse (trace . show) params $> Unit - Closure _ _ _ _ _ (Left Show) _ _ -> pure . String . pack $ show params - Closure packageInfo moduleInfo _ maybeSelf names (Right body) associatedScope parentFrame -> do - -- Evaluate the bindings and body with the closure’s package/module info in scope in order to - -- charge them to the closure's origin. - withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do - parentScope <- scopeLookup parentFrame - let frameEdges = Map.singleton Lexical (Map.singleton parentScope parentFrame) - frameAddress <- newFrame associatedScope frameEdges - withScopeAndFrame frameAddress $ do - case maybeSelf of - Just object -> do - maybeSlot <- maybeLookupDeclaration (Declaration __self) - maybe (pure ()) (`assign` object) maybeSlot - Nothing -> pure () - for_ (zip names params) $ \(name, param) -> do - slot <- lookupSlot (Declaration name) - assign slot param - catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body))) - _ -> throwValueError (CallError op) - Evaluator $ runFunctionC (k boxed) eval) op) + case op of + Abstract.Function name params body scope k -> do + val <- closure (Just name) params (Right body) scope + Evaluator (k val) + Abstract.BuiltIn associatedScope builtIn k -> do + val <- closure Nothing [] (Left builtIn) associatedScope + Evaluator (k val) + Abstract.Bind obj@Object{} (Closure packageInfo moduleInfo name _ names body scope parentFrame) k -> + Evaluator (k (Closure packageInfo moduleInfo name (Just obj) names body scope parentFrame)) + Abstract.Bind _ value k -> Evaluator (k value) + Abstract.Call op params k -> do + boxed <- case op of + Closure _ _ _ _ _ (Left Print) _ _ -> traverse (trace . show) params $> Unit + Closure _ _ _ _ _ (Left Show) _ _ -> pure . String . pack $ show params + Closure packageInfo moduleInfo _ maybeSelf names (Right body) associatedScope parentFrame -> do + -- Evaluate the bindings and body with the closure’s package/module info in scope in order to + -- charge them to the closure's origin. + withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do + parentScope <- scopeLookup parentFrame + let frameEdges = Map.singleton Lexical (Map.singleton parentScope parentFrame) + frameAddress <- newFrame associatedScope frameEdges + withScopeAndFrame frameAddress $ do + case maybeSelf of + Just object -> do + maybeSlot <- maybeLookupDeclaration (Declaration __self) + maybe (pure ()) (`assign` object) maybeSlot + Nothing -> pure () + for_ (zip names params) $ \(name, param) -> do + slot <- lookupSlot (Declaration name) + assign slot param + catchReturn (Evaluator (eval body)) + _ -> throwValueError (CallError op) + Evaluator (k boxed) instance ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig @@ -126,11 +127,11 @@ instance ( Member (Reader ModuleInfo) sig , Monad m ) => Carrier (Abstract.Boolean (Value term address) :+: sig) (BooleanC (Value term address) m) where - ret = BooleanC . ret - eff = BooleanC . handleSum (eff . handleCoercible) (\case - Abstract.Boolean b k -> runBooleanC . k $! Boolean b - Abstract.AsBool (Boolean b) k -> runBooleanC (k b) - Abstract.AsBool other k -> throwBaseError (BoolError other) >>= runBooleanC . k) + eff (R other) = BooleanC . eff . handleCoercible $ other + eff (L op) = case op of + Abstract.Boolean b k -> k $! Boolean b + Abstract.AsBool (Boolean b) k -> k b + Abstract.AsBool other k -> throwBaseError (BoolError other) >>= k instance ( Carrier sig m @@ -138,8 +139,7 @@ instance ( Carrier sig m , Member (Error (LoopControl (Value term address))) sig , Member (Interpose (Resumable (BaseError (UnspecializedError address (Value term address))))) sig ) - => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) (Eff m)) where - ret = WhileC . ret + => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where eff = WhileC . handleSum (eff . handleCoercible) (\case Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do cond' <- Evaluator (runWhileC cond) @@ -165,10 +165,8 @@ instance ( Carrier sig m instance Carrier sig m => Carrier (Abstract.Unit (Value term address) :+: sig) (UnitC (Value term address) m) where - ret = UnitC . ret - eff = UnitC . handleSum - (eff . handleCoercible) - (\ (Abstract.Unit k) -> runUnitC (k Unit)) + eff (R other) = UnitC . eff . handleCoercible $ other + eff (L (Abstract.Unit k )) = k Unit instance ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig @@ -177,11 +175,11 @@ instance ( Member (Reader ModuleInfo) sig , Monad m ) => Carrier (Abstract.String (Value term address) :+: sig) (StringC (Value term address) m) where - ret = StringC . ret - eff = StringC . handleSum (eff . handleCoercible) (\case - Abstract.String t k -> runStringC (k (String t)) - Abstract.AsString (String t) k -> runStringC (k t) - Abstract.AsString other k -> throwBaseError (StringError other) >>= runStringC . k) + eff (R other) = StringC . eff . handleCoercible $ other + eff (L op) = case op of + Abstract.String t k -> k (String t) + Abstract.AsString (String t) k -> k t + Abstract.AsString other k -> throwBaseError (StringError other) >>= k instance ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig @@ -190,17 +188,17 @@ instance ( Member (Reader ModuleInfo) sig , Monad m ) => Carrier (Abstract.Numeric (Value term address) :+: sig) (NumericC (Value term address) m) where - ret = NumericC . ret - eff = NumericC . handleSum (eff . handleCoercible) (\case - Abstract.Integer t k -> runNumericC (k (Integer (Number.Integer t))) - Abstract.Float t k -> runNumericC (k (Float (Number.Decimal t))) - Abstract.Rational t k -> runNumericC (k (Rational (Number.Ratio t))) - Abstract.LiftNumeric f arg k -> runNumericC . k =<< case arg of + eff (R other) = NumericC . eff . handleCoercible $ other + eff (L op) = case op of + Abstract.Integer t k -> k (Integer (Number.Integer t)) + Abstract.Float t k -> k (Float (Number.Decimal t)) + Abstract.Rational t k -> k (Rational (Number.Ratio t)) + Abstract.LiftNumeric f arg k -> k =<< case arg of Integer (Number.Integer i) -> pure $ Integer (Number.Integer (f i)) Float (Number.Decimal d) -> pure $ Float (Number.Decimal (f d)) Rational (Number.Ratio r) -> pure $ Rational (Number.Ratio (f r)) other -> throwBaseError (NumericError other) - Abstract.LiftNumeric2 f left right k -> runNumericC . k =<< case (left, right) of + Abstract.LiftNumeric2 f left right k -> k =<< case (left, right) of (Integer i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize (Integer i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize (Integer i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize @@ -210,7 +208,7 @@ instance ( Member (Reader ModuleInfo) sig (Float i, Integer j) -> attemptUnsafeArithmetic (f i j) & specialize (Float i, Rational j) -> attemptUnsafeArithmetic (f i j) & specialize (Float i, Float j) -> attemptUnsafeArithmetic (f i j) & specialize - _ -> throwBaseError (Numeric2Error left right)) + _ -> throwBaseError (Numeric2Error left right) -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor specialize :: ( Member (Reader ModuleInfo) sig @@ -223,8 +221,8 @@ specialize :: ( Member (Reader ModuleInfo) sig -> m (Value term address) specialize (Left exc) = throwBaseError (ArithmeticError exc) specialize (Right (Number.SomeNumber (Number.Integer t))) = pure (Integer (Number.Integer t)) -specialize (Right (Number.SomeNumber (Number.Decimal t))) = pure (Float (Number.Decimal t)) -specialize (Right (Number.SomeNumber (Number.Ratio t))) = pure (Rational (Number.Ratio t)) +specialize (Right (Number.SomeNumber (Number.Decimal t))) = pure (Float (Number.Decimal t)) +specialize (Right (Number.SomeNumber (Number.Ratio t))) = pure (Rational (Number.Ratio t)) instance ( Member (Reader ModuleInfo) sig @@ -234,32 +232,31 @@ instance ( Member (Reader ModuleInfo) sig , Monad m ) => Carrier (Abstract.Bitwise (Value term address) :+: sig) (BitwiseC (Value term address) m) where - ret = BitwiseC . ret - eff = BitwiseC . handleSum (eff . handleCoercible) (\case - CastToInteger (Integer (Number.Integer i)) k -> runBitwiseC (k (Integer (Number.Integer i))) - CastToInteger (Float (Number.Decimal i)) k -> runBitwiseC (k (Integer (Number.Integer (coefficient (normalize i))))) - CastToInteger i k -> throwBaseError (NumericError i) >>= runBitwiseC . k - LiftBitwise operator (Integer (Number.Integer i)) k -> runBitwiseC . k . Integer . Number.Integer . operator $ i - LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= runBitwiseC . k - LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> runBitwiseC . k . Integer . Number.Integer $ operator i j - LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k - UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> runBitwiseC . k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j) - UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= runBitwiseC . k) + eff (R other) = BitwiseC . eff . handleCoercible $ other + eff (L op) = case op of + CastToInteger (Integer (Number.Integer i)) k -> k (Integer (Number.Integer i)) + CastToInteger (Float (Number.Decimal i)) k -> k (Integer (Number.Integer (coefficient (normalize i)))) + CastToInteger i k -> throwBaseError (NumericError i) >>= k + LiftBitwise operator (Integer (Number.Integer i)) k -> k . Integer . Number.Integer . operator $ i + LiftBitwise _ other k -> throwBaseError (BitwiseError other) >>= k + LiftBitwise2 operator (Integer (Number.Integer i)) (Integer (Number.Integer j)) k -> k . Integer . Number.Integer $ operator i j + LiftBitwise2 _ left right k -> throwBaseError (Bitwise2Error left right) >>= k + UnsignedRShift (Integer (Number.Integer i)) (Integer (Number.Integer j)) k | i >= 0 -> k . Integer . Number.Integer $ ourShift (fromIntegral i) (fromIntegral j) + UnsignedRShift left right k -> throwBaseError (Bitwise2Error left right) >>= k ourShift :: Word64 -> Int -> Integer ourShift a b = toInteger (shiftR a b) instance Carrier sig m => Carrier (Abstract.Object address (Value term address) :+: sig) (ObjectC address (Value term address) m) where - ret = ObjectC . ret - eff = ObjectC . handleSum (eff . handleCoercible) (\case - Abstract.Object address k -> runObjectC (k (Object address)) - Abstract.ScopedEnvironment (Object address) k -> runObjectC (k (Just address)) - Abstract.ScopedEnvironment (Class _ _ address) k -> runObjectC (k (Just address)) - Abstract.ScopedEnvironment (Namespace _ address) k -> runObjectC (k (Just address)) - Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing) - Abstract.Klass n frame k -> runObjectC (k (Class n mempty frame)) - ) + eff (R other) = ObjectC . eff . handleCoercible $ other + eff (L op) = case op of + Abstract.Object address k -> k (Object address) + Abstract.ScopedEnvironment (Object address) k -> k (Just address) + Abstract.ScopedEnvironment (Class _ _ address) k -> k (Just address) + Abstract.ScopedEnvironment (Namespace _ address) k -> k (Just address) + Abstract.ScopedEnvironment _ k -> k Nothing + Abstract.Klass n frame k -> k (Class n mempty frame) instance ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig @@ -268,17 +265,17 @@ instance ( Member (Reader ModuleInfo) sig , Monad m ) => Carrier (Abstract.Array (Value term address) :+: sig) (ArrayC (Value term address) m) where - ret = ArrayC . ret - eff = ArrayC . handleSum (eff . handleCoercible) (\case - Abstract.Array t k -> runArrayC (k (Array t)) - Abstract.AsArray (Array addresses) k -> runArrayC (k addresses) - Abstract.AsArray val k -> throwBaseError (ArrayError val) >>= runArrayC . k) + eff (R other) = ArrayC . eff . handleCoercible $ other + eff (L op) = case op of + Abstract.Array t k -> k (Array t) + Abstract.AsArray (Array addresses) k -> k addresses + Abstract.AsArray val k -> throwBaseError (ArrayError val) >>= k instance ( Carrier sig m ) => Carrier (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where - ret = HashC . ret - eff = HashC . handleSum (eff . handleCoercible) (\case - Abstract.Hash t k -> runHashC (k ((Hash . map (uncurry KVPair)) t)) - Abstract.KvPair t v k -> runHashC (k (KVPair t v))) + eff (R other) = ArrayC . eff . handleCoercible $ other + eff (L op) = case op of + Abstract.Hash t k -> k ((Hash . map (uncurry KVPair)) t) + Abstract.KvPair t v k -> k (KVPair t v) instance AbstractHole (Value term address) where @@ -392,13 +389,13 @@ instance (Show address, Show term) => Show1 (ValueError term address) where liftShowsPrec _ _ = showsPrec runValueError :: (Carrier sig m, Effect sig) - => Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) (Eff m)) a + => Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) m) a -> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a) runValueError = Evaluator . runResumable . runEvaluator runValueErrorWith :: Carrier sig m => (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume) - -> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff m)) a + -> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) m) a -> Evaluator term address (Value term address) m a runValueErrorWith f = Evaluator . runResumableWith (runEvaluator . f) . runEvaluator diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index 2b9605b43..fd42659de 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -87,10 +87,10 @@ instance Ord1 TypeError where instance Show1 TypeError where liftShowsPrec _ _ = showsPrec -runTypeError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError TypeError) (Eff m)) a -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a) +runTypeError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError TypeError) m) a -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a) runTypeError = raiseHandler runResumable -runTypeErrorWith :: Carrier sig m => (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError TypeError) (Eff m)) a -> Evaluator term address value m a +runTypeErrorWith :: Carrier sig m => (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError TypeError) m) a -> Evaluator term address value m a runTypeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) @@ -105,22 +105,21 @@ throwTypeError :: ( Member (Resumable (BaseError TypeError)) sig throwTypeError = throwBaseError runTypeMap :: (Carrier sig m, Effect sig) - => Evaluator term address Type (StateC TypeMap (Eff m)) a + => Evaluator term address Type (StateC TypeMap m) a -> Evaluator term address Type m a runTypeMap = raiseHandler $ fmap snd . runState emptyTypeMap runTypes :: (Carrier sig m, Effect sig) - => Evaluator term address Type (ResumableC (BaseError TypeError) (Eff - (StateC TypeMap (Eff - m)))) a + => Evaluator term address Type (ResumableC (BaseError TypeError) + (StateC TypeMap m)) a -> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a) runTypes = runTypeMap . runTypeError runTypesWith :: (Carrier sig m, Effect sig) - => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap (Eff m)) resume) - -> Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff - (StateC TypeMap (Eff - m)))) a + => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap m) resume) + -> Evaluator term address Type (ResumableWithC (BaseError TypeError) + (StateC TypeMap + m)) a -> Evaluator term address Type m a runTypesWith with = runTypeMap . runTypeErrorWith with @@ -256,35 +255,38 @@ instance ( Member (Allocator address) sig , Show address , Carrier sig m ) - => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type (Eff m)) where - ret = FunctionC . const . ret - eff op = FunctionC (\ eval -> handleSum (eff . handleReader eval runFunctionC) (\case - Abstract.Function _ params body scope k -> runEvaluator $ do - currentScope' <- currentScope - currentFrame' <- currentFrame - let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame') - frame <- newFrame scope frameLinks - res <- withScopeAndFrame frame $ do - tvars <- foldr (\ param rest -> do - tvar <- Var <$> fresh - slot <- lookupSlot (Declaration param) - assign slot tvar - (tvar :) <$> rest) (pure []) params - -- TODO: We may still want to represent this as a closure and not a function type - (zeroOrMoreProduct tvars :->) <$> catchReturn (runFunction (Evaluator . eval) (Evaluator (eval body))) - Evaluator (runFunctionC (k res) eval) + => Carrier (Abstract.Function term address Type :+: sig) (FunctionC term address Type m) where + eff (R other) = FunctionC (eff (R (handleCoercible other))) + eff (L op) = runEvaluator $ do + eval <- Evaluator . FunctionC $ ask + case op of + Abstract.Function _ params body scope k -> do + currentScope' <- currentScope + currentFrame' <- currentFrame + let frameLinks = Map.singleton Lexical (Map.singleton currentScope' currentFrame') + frame <- newFrame scope frameLinks + res <- withScopeAndFrame frame $ do + tvars <- foldr (\ param rest -> do + tvar <- Var <$> fresh + slot <- lookupSlot (Declaration param) + assign slot tvar + (tvar :) <$> rest) (pure []) params + -- TODO: We may still want to represent this as a closure and not a function type + (zeroOrMoreProduct tvars :->) <$> catchReturn (Evaluator (eval body)) + Evaluator (k res) + + Abstract.BuiltIn _ Print k -> Evaluator $ k (String :-> Unit) + Abstract.BuiltIn _ Show k -> Evaluator $ k (Object :-> String) + Abstract.Bind _ value k -> Evaluator $ k value + Abstract.Call op paramTypes k -> do + tvar <- fresh + let needed = zeroOrMoreProduct paramTypes :-> Var tvar + unified <- op `unify` needed + boxed <- case unified of + _ :-> ret -> pure ret + actual -> throwTypeError (UnificationError needed actual) + Evaluator (k boxed) - Abstract.BuiltIn _ Print k -> runFunctionC (k (String :-> Unit)) eval - Abstract.BuiltIn _ Show k -> runFunctionC (k (Object :-> String)) eval - Abstract.Bind _ value k -> runFunctionC (k value) eval - Abstract.Call op paramTypes k -> runEvaluator $ do - tvar <- fresh - let needed = zeroOrMoreProduct paramTypes :-> Var tvar - unified <- op `unify` needed - boxed <- case unified of - _ :-> ret -> pure ret - actual -> throwTypeError (UnificationError needed actual) - Evaluator $ runFunctionC (k boxed) eval) op) instance ( Member (Reader ModuleInfo) sig @@ -296,10 +298,10 @@ instance ( Member (Reader ModuleInfo) sig , Monad m ) => Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where - ret = BooleanC . ret - eff = BooleanC . handleSum (eff . handleCoercible) (\case - Abstract.Boolean _ k -> runBooleanC (k Bool) - Abstract.AsBool t k -> unify t Bool *> (runBooleanC (k True) <|> runBooleanC (k False))) + eff (R other) = BooleanC . eff . handleCoercible $ other + eff (L (Abstract.Boolean _ k)) = k Bool + eff (L (Abstract.AsBool t k)) = unify t Bool *> (k True <|> k False) + instance ( Member (Abstract.Boolean Type) sig @@ -308,20 +310,16 @@ instance ( Member (Abstract.Boolean Type) sig , Monad m ) => Carrier (Abstract.While Type :+: sig) (WhileC Type m) where - ret = WhileC . ret - eff = WhileC . handleSum - (eff . handleCoercible) - (\ (Abstract.While cond body k) -> do - cond' <- runWhileC cond - ifthenelse cond' (runWhileC body *> empty) (runWhileC (k Unit))) + eff (R other) = WhileC . eff . handleCoercible $ other + eff (L (Abstract.While cond body k)) = do + cond' <- cond + ifthenelse cond' (body *> empty) (k Unit) instance Carrier sig m => Carrier (Abstract.Unit Type :+: sig) (UnitC Type m) where - ret = UnitC . ret - eff = UnitC . handleSum - (eff . handleCoercible) - (\ (Abstract.Unit k) -> runUnitC (k Unit)) + eff (R other) = UnitC . eff . handleCoercible $ other + eff (L (Abstract.Unit k)) = k Unit instance ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig @@ -332,10 +330,9 @@ instance ( Member (Reader ModuleInfo) sig , Monad m ) => Carrier (Abstract.String Type :+: sig) (StringC Type m) where - ret = StringC . ret - eff = StringC . handleSum (eff . handleCoercible) (\case - Abstract.String _ k -> runStringC (k String) - Abstract.AsString t k -> unify t String *> runStringC (k "")) + eff (R other) = StringC . eff . handleCoercible $ other + eff (L (Abstract.String _ k)) = k String + eff (L (Abstract.AsString t k)) = unify t String *> k "" instance ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig @@ -345,16 +342,16 @@ instance ( Member (Reader ModuleInfo) sig , Monad m ) => Carrier (Abstract.Numeric Type :+: sig) (NumericC Type m) where - ret = NumericC . ret - eff = NumericC . handleSum (eff . handleCoercible) (\case - Abstract.Integer _ k -> runNumericC (k Int) - Abstract.Float _ k -> runNumericC (k Float) - Abstract.Rational _ k -> runNumericC (k Rational) - Abstract.LiftNumeric _ t k -> unify (Int :+ Float :+ Rational) t >>= runNumericC . k + eff (R other) = NumericC . eff . handleCoercible $ other + eff (L op) = case op of + Abstract.Integer _ k -> k Int + Abstract.Float _ k -> k Float + Abstract.Rational _ k -> k Rational + Abstract.LiftNumeric _ t k -> unify (Int :+ Float :+ Rational) t >>= k Abstract.LiftNumeric2 _ left right k -> case (left, right) of - (Float, Int) -> runNumericC (k Float) - (Int, Float) -> runNumericC (k Float) - _ -> unify left right >>= runNumericC . k) + (Float, Int) -> k Float + (Int, Float) -> k Float + _ -> unify left right >>= k instance ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig @@ -364,19 +361,19 @@ instance ( Member (Reader ModuleInfo) sig , Monad m ) => Carrier (Abstract.Bitwise Type :+: sig) (BitwiseC Type m) where - ret = BitwiseC . ret - eff = BitwiseC . handleSum (eff . handleCoercible) (\case - CastToInteger t k -> unify t (Int :+ Float :+ Rational) >> runBitwiseC (k Int) - LiftBitwise _ t k -> unify t Int >>= runBitwiseC . k - LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= runBitwiseC . k - UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= runBitwiseC . k) + eff (R other) = BitwiseC . eff . handleCoercible $ other + eff (L op) = case op of + CastToInteger t k -> unify t (Int :+ Float :+ Rational) *> k Int + LiftBitwise _ t k -> unify t Int >>= k + LiftBitwise2 _ t1 t2 k -> unify Int t1 >>= unify t2 >>= k + UnsignedRShift t1 t2 k -> unify Int t2 *> unify Int t1 >>= k instance ( Carrier sig m ) => Carrier (Abstract.Object address Type :+: sig) (ObjectC address Type m) where - ret = ObjectC . ret - eff = ObjectC . handleSum (eff . handleCoercible) (\case - Abstract.Object _ k -> runObjectC (k Object) - Abstract.ScopedEnvironment _ k -> runObjectC (k Nothing) - Abstract.Klass _ _ k -> runObjectC (k Object)) + eff (R other) = ObjectC . eff . handleCoercible $ other + eff (L op) = case op of + Abstract.Object _ k -> k Object + Abstract.ScopedEnvironment _ k -> k Nothing + Abstract.Klass _ _ k -> k Object instance ( Member Fresh sig , Member (Reader ModuleInfo) sig @@ -387,21 +384,19 @@ instance ( Member Fresh sig , Monad m ) => Carrier (Abstract.Array Type :+: sig) (ArrayC Type m) where - ret = ArrayC . ret - eff = ArrayC . handleSum (eff . handleCoercible) (\case - Abstract.Array fieldTypes k -> do - var <- fresh - fieldType <- foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes - runArrayC (k (Array fieldType)) - Abstract.AsArray t k -> do - field <- fresh - unify t (Array (Var field)) >> runArrayC (k mempty)) + eff (R other) = ArrayC . eff . handleCoercible $ other + eff (L (Abstract.Array fieldTypes k)) = do + var <- fresh + fieldType <- foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fieldTypes + k (Array fieldType) + eff (L (Abstract.AsArray t k)) = do + field <- fresh + unify t (Array (Var field)) >> k mempty instance ( Carrier sig m ) => Carrier (Abstract.Hash Type :+: sig) (HashC Type m) where - ret = HashC . ret - eff = HashC . handleSum (eff . handleCoercible) (\case - Abstract.Hash t k -> runHashC (k (Hash t)) - Abstract.KvPair t1 t2 k -> runHashC (k (t1 :* t2))) + eff (R other) = HashC . eff . handleCoercible $ other + eff (L (Abstract.Hash t k)) = k (Hash t) + eff (L (Abstract.KvPair t1 t2 k)) = k (t1 :* t2) instance AbstractHole Type where diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index fbde37f5b..759579674 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -17,28 +17,28 @@ import Prologue import qualified Data.Map.Strict as Map type ModuleC address value m - = ErrorC (LoopControl value) (Eff - ( ErrorC (Return value) (Eff - ( ReaderC (CurrentScope address) (Eff - ( ReaderC (CurrentFrame address) (Eff - ( DerefC address value (Eff - ( AllocatorC address (Eff - ( ReaderC ModuleInfo (Eff - m))))))))))))) + = ErrorC (LoopControl value) + ( ErrorC (Return value) + ( ReaderC (CurrentScope address) + ( ReaderC (CurrentFrame address) + ( DerefC address value + ( AllocatorC address + ( ReaderC ModuleInfo + m)))))) type DomainC term address value m - = FunctionC term address value (Eff - ( WhileC value (Eff - ( BooleanC value (Eff - ( StringC value (Eff - ( NumericC value (Eff - ( BitwiseC value (Eff - ( ObjectC address value (Eff - ( ArrayC value (Eff - ( HashC value (Eff - ( UnitC value (Eff - ( InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff - m))))))))))))))))))))) + = FunctionC term address value + ( WhileC value + ( BooleanC value + ( StringC value + ( NumericC value + ( BitwiseC value + ( ObjectC address value + ( ArrayC value + ( HashC value + ( UnitC value + ( InterposeC (Resumable (BaseError (UnspecializedError address value))) + m)))))))))) -- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module. evaluate :: ( Carrier outerSig outer diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index 96fafb2ca..a3f8f2ae8 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -48,12 +48,12 @@ instance Effect Distribute where -- | Evaluate a 'Distribute' effect concurrently. -runDistribute :: DistributeC (LiftC IO) a -> Eff (LiftC IO) a +runDistribute :: DistributeC (LiftC IO) a -> LiftC IO a runDistribute = runDistributeC newtype DistributeC m a = DistributeC { runDistributeC :: m a } deriving (Functor, Applicative, Monad) -instance Carrier (Distribute :+: Lift IO) (DistributeC (Eff (LiftC IO))) where +instance Carrier (Distribute :+: Lift IO) (DistributeC (LiftC IO)) where eff (L (Distribute task k)) = liftIO (Async.runConcurrently (Async.Concurrently (runM task))) >>= k eff (R other) = DistributeC (eff (handleCoercible other)) diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index e2f7ea940..27b9e237f 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -38,9 +38,9 @@ runTagging blob tree type ContextToken = (Text, Maybe Range) type Contextualizer - = Eff (StateC [ContextToken] - ( Eff (ErrorC TranslationError - ( Eff VoidC)))) + = StateC [ContextToken] + ( ErrorC TranslationError + ( VoidC)) contextualizing :: Blob -> Machine.ProcessT Contextualizer Token Tag contextualizing Blob{..} = repeatedly $ await >>= \case From 4cfcda5aaf30d4d153adfe8af151e81d0fd0bfc4 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 5 Mar 2019 16:22:59 -0500 Subject: [PATCH 20/32] WIP --- .../Abstract/Caching/FlowInsensitive.hs | 11 ++- .../Abstract/Caching/FlowSensitive.hs | 16 ++--- src/Control/Abstract/PythonPackage.hs | 61 ++++++++-------- src/Data/Abstract/Address/Hole.hs | 12 ++-- src/Data/Abstract/Address/Precise.hs | 12 ++-- src/Data/Abstract/BaseError.hs | 1 - src/Data/Abstract/Name.hs | 2 +- src/Data/Abstract/Value/Abstract.hs | 72 ++++++++++--------- src/Data/Abstract/Value/Concrete.hs | 47 ++++++------ src/Data/Abstract/Value/Type.hs | 22 +++--- src/Data/Project.hs | 2 +- src/Diffing/Interpreter.hs | 3 +- src/Rendering/Graph.hs | 2 - src/Semantic/Analysis.hs | 4 +- 14 files changed, 127 insertions(+), 140 deletions(-) diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs index aae78df92..1c59adf41 100644 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -54,14 +54,14 @@ isolateCache action = putCache lowerBound *> action *> ((,) <$> get <*> get) -- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. -cachingTerms :: ( Member NonDet sig - , Member (Reader (Cache term address value)) sig +cachingTerms :: ( Member (Reader (Cache term address value)) sig , Member (Reader (Live address)) sig , Member (State (Cache term address value)) sig , Carrier sig m , Ord address , Ord term , Ord value + , Alternative m ) => Open (term -> Evaluator term address value m value) cachingTerms recur term = do @@ -75,7 +75,6 @@ cachingTerms recur term = do convergingModules :: ( Eq value , Member Fresh sig - , Member NonDet sig , Member (Reader (Cache term address value)) sig , Member (Reader (Live address)) sig , Member (State (Cache term address value)) sig @@ -83,7 +82,7 @@ convergingModules :: ( Eq value , Ord address , Ord term , Carrier sig m - , Effect sig + , Alternative m ) => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe m) value) -> (Module (Either prelude term) -> Evaluator term address value m value) @@ -119,7 +118,7 @@ converge seed f = loop seed loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Foldable t, Member NonDet sig, Carrier sig m) => t value -> Evaluator term address value m value +scatter :: (Foldable t, Carrier sig m, Alternative m) => t value -> Evaluator term address value m value scatter = foldMapA pure -- | Get the current 'Configuration' with a passed-in term. @@ -129,7 +128,7 @@ getConfiguration :: (Member (Reader (Live address)) sig, Carrier sig m) getConfiguration term = Configuration term <$> askRoots -caching :: (Carrier sig m, Effect sig) +caching :: Carrier sig m => Evaluator term address value (AltC B (ReaderC (Cache term address value) (StateC (Cache term address value) diff --git a/src/Analysis/Abstract/Caching/FlowSensitive.hs b/src/Analysis/Abstract/Caching/FlowSensitive.hs index 41359bcac..5adadf611 100644 --- a/src/Analysis/Abstract/Caching/FlowSensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowSensitive.hs @@ -56,12 +56,12 @@ isolateCache action = putCache lowerBound *> action *> get -- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. cachingTerms :: ( Cacheable term address value - , Member NonDet sig , Member (Reader (Cache term address value)) sig , Member (Reader (Live address)) sig , Member (State (Cache term address value)) sig , Member (State (Heap address address value)) sig , Carrier sig m + , Alternative m ) => Open (term -> Evaluator term address value m value) cachingTerms recur term = do @@ -75,13 +75,12 @@ cachingTerms recur term = do convergingModules :: ( Cacheable term address value , Member Fresh sig - , Member NonDet sig , Member (Reader (Cache term address value)) sig , Member (Reader (Live address)) sig , Member (State (Cache term address value)) sig , Member (State (Heap address address value)) sig , Carrier sig m - , Effect sig + , Alternative m ) => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe m) value) -> (Module (Either prelude term) -> Evaluator term address value m value) @@ -117,7 +116,7 @@ converge seed f = loop seed loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Foldable t, Member NonDet sig, Member (State (Heap address address value)) sig, Carrier sig m) => t (Cached address value) -> Evaluator term address value m value +scatter :: (Foldable t, Member (State (Heap address address value)) sig, Alternative m, Carrier sig m) => t (Cached address value) -> Evaluator term address value m value scatter = foldMapA (\ (Cached value heap') -> putHeap heap' $> value) -- | Get the current 'Configuration' with a passed-in term. @@ -127,11 +126,10 @@ getConfiguration :: (Member (Reader (Live address)) sig, Member (State (Heap add getConfiguration term = Configuration term <$> askRoots <*> getHeap -caching :: (Carrier sig m, Effect sig) - => Evaluator term address value (AltC [] (Eff - (ReaderC (Cache term address value) (Eff - (StateC (Cache term address value) (Eff - m)))))) a +caching :: Evaluator term address value (AltC [] + (ReaderC (Cache term address value) + (StateC (Cache term address value) + m))) a -> Evaluator term address value m (Cache term address value, [a]) caching = raiseHandler (runState lowerBound) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 650600feb..1e10f188b 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-} module Control.Abstract.PythonPackage ( runPythonPackaging, Strategy(..) ) where @@ -19,14 +19,15 @@ runPythonPackaging :: ( Carrier sig m , Member (Abstract.Array (Value term address)) sig , Member (State Strategy) sig , Member (Function term address (Value term address)) sig) - => Evaluator term address (Value term address) (PythonPackagingC term address (Eff m)) a + => Evaluator term address (Value term address) (PythonPackagingC term address m) a -> Evaluator term address (Value term address) m a -runPythonPackaging = raiseHandler (runPythonPackagingC . interpret) +runPythonPackaging = raiseHandler runPythonPackagingC newtype PythonPackagingC term address m a = PythonPackagingC { runPythonPackagingC :: m a } + deriving (Applicative, Functor, Monad) -wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address (Eff m) a +wrap :: Evaluator term address (Value term address) m a -> PythonPackagingC term address m a wrap = PythonPackagingC . runEvaluator instance ( Carrier sig m @@ -35,30 +36,30 @@ instance ( Carrier sig m , Member (Abstract.String (Value term address)) sig , Member (Abstract.Array (Value term address)) sig ) - => Carrier sig (PythonPackagingC term address (Eff m)) where - ret = PythonPackagingC . ret - eff op - | Just e <- prj op = wrap $ case handleCoercible e of - Call callName params k -> Evaluator . k =<< do - case callName of - Closure _ _ name' _ paramNames _ _ _ -> do - let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params) - let asStrings = asArray >=> traverse asString + => Carrier sig (PythonPackagingC term address m) where + -- eff (R other) = PythonPackagingC . eff . handleCoercible $ other + -- eff (L op) + -- | Just e <- prj op = wrap $ case handleCoercible e of + -- Call callName params k -> Evaluator . k =<< do + -- case callName of + -- Closure _ _ name' _ paramNames _ _ _ -> do + -- let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params) + -- let asStrings = asArray >=> traverse asString - if Just (name "find_packages") == name' then do - as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings) - put (FindPackages as) - else if Just (name "setup") == name' then do - packageState <- get - if packageState == Control.Abstract.PythonPackage.Unknown then do - as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings) - put (Packages as) - else - pure () - else pure () - _ -> pure () - call callName params - Function name params body scope k -> function name params body scope >>= Evaluator . k - BuiltIn n b k -> builtIn n b >>= Evaluator . k - Bind obj value k -> bindThis obj value >>= Evaluator . k - | otherwise = PythonPackagingC (eff (handleCoercible op)) + -- if Just (name "find_packages") == name' then do + -- as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings) + -- put (FindPackages as) + -- else if Just (name "setup") == name' then do + -- packageState <- get + -- if packageState == Control.Abstract.PythonPackage.Unknown then do + -- as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings) + -- put (Packages as) + -- else + -- pure () + -- else pure () + -- _ -> pure () + -- call callName params + -- Function name params body scope k -> function name params body scope >>= Evaluator . k + -- BuiltIn n b k -> builtIn n b >>= Evaluator . k + -- Bind obj value k -> bindThis obj value >>= Evaluator . k + -- | otherwise = PythonPackagingC (eff (handleCoercible op)) diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index 651fcdb7a..8144ccb11 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -28,9 +28,8 @@ instance ( Carrier (Allocator address :+: sig) (AllocatorC address m) , Monad m ) => Carrier (Allocator (Hole context address) :+: sig) (AllocatorC (Hole context address) m) where - eff = handleSum - (AllocatorC . eff . handleCoercible) - (\ (Alloc name k) -> Total <$> promoteA (eff (L (Alloc name ret))) >>= k) + eff (R other) = AllocatorC . eff . handleCoercible $ other + eff (L (Alloc name k)) = Total <$> promoteA (eff (L (Alloc name pure))) >>= k promoteD :: DerefC address value m a -> DerefC (Hole context address) value m a @@ -38,6 +37,7 @@ promoteD = DerefC . runDerefC instance (Carrier (Deref value :+: sig) (DerefC address value m), Carrier sig m) => Carrier (Deref value :+: sig) (DerefC (Hole context address) value m) where - eff = handleSum (DerefC . eff . handleCoercible) (\case - DerefCell cell k -> promoteD (eff (L (DerefCell cell ret))) >>= k - AssignCell value cell k -> promoteD (eff (L (AssignCell value cell ret))) >>= k) + eff (R other) = DerefC . eff . handleCoercible $ other + eff (L op) = case op of + DerefCell cell k -> promoteD (eff (L (DerefCell cell pure))) >>= k + AssignCell value cell k -> promoteD (eff (L (AssignCell value cell pure))) >>= k diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index e7c2110e7..82f58f913 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -19,12 +19,12 @@ instance Show Precise where instance (Member Fresh sig, Carrier sig m) => Carrier (Allocator Precise :+: sig) (AllocatorC Precise m) where - eff = AllocatorC . handleSum - (eff . handleCoercible) - (\ (Alloc _ k) -> Precise <$> fresh >>= runAllocatorC . k) + eff (R other) = AllocatorC . eff . handleCoercible $ other + eff (L (Alloc _ k)) = Precise <$> fresh >>= k instance Carrier sig m => Carrier (Deref value :+: sig) (DerefC Precise value m) where - eff = DerefC . handleSum (eff . handleCoercible) (\case - DerefCell cell k -> runDerefC (k (fst <$> Set.minView cell)) - AssignCell value _ k -> runDerefC (k (Set.singleton value))) + eff (R other) = DerefC . eff . handleCoercible $ other + eff (L op) = case op of + DerefCell cell k -> k (fst <$> Set.minView cell) + AssignCell value _ k -> k (Set.singleton value) diff --git a/src/Data/Abstract/BaseError.hs b/src/Data/Abstract/BaseError.hs index 8d9061d3b..2fc28e492 100644 --- a/src/Data/Abstract/BaseError.hs +++ b/src/Data/Abstract/BaseError.hs @@ -39,7 +39,6 @@ throwBaseError :: ( Member (Resumable (BaseError exc)) sig , Member (Reader M.ModuleInfo) sig , Member (Reader S.Span) sig , Carrier sig m - , Monad m ) => exc resume -> m resume diff --git a/src/Data/Abstract/Name.hs b/src/Data/Abstract/Name.hs index d4d8db29b..66d9bb4b2 100644 --- a/src/Data/Abstract/Name.hs +++ b/src/Data/Abstract/Name.hs @@ -24,7 +24,7 @@ data Name deriving (Eq, Ord, Generic, NFData) -- | Generate a fresh (unused) name for use in synthesized variables/closures/etc. -gensym :: (Member Fresh sig, Carrier sig m, Functor m) => m Name +gensym :: (Member Fresh sig, Carrier sig m) => m Name gensym = I <$> fresh -- | Construct a 'Name' from a 'Text'. diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index f0228c73e..4bb8847a1 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -68,63 +68,65 @@ instance (Carrier sig m, Alternative m) => Carrier (Boolean Abstract :+: sig) (B instance ( Member (Abstract.Boolean Abstract) sig , Carrier sig m , Alternative m - , Monad m ) => Carrier (While Abstract :+: sig) (WhileC Abstract m) where - eff = WhileC . handleSum - (eff . handleCoercible) - (\ (Abstract.While cond body k) -> do - cond' <- runWhileC cond - ifthenelse cond' (runWhileC body *> empty) (runWhileC (k Abstract))) - + eff (R other) = WhileC . eff . handleCoercible $ other + eff (L (Abstract.While cond body k)) = do + cond' <- cond + ifthenelse cond' (body *> empty) (k Abstract) instance Carrier sig m => Carrier (Unit Abstract :+: sig) (UnitC Abstract m) where - eff = UnitC . handleSum - (eff . handleCoercible) - (\ (Abstract.Unit k) -> runUnitC (k Abstract)) + eff (R other) = UnitC . eff . handleCoercible $ other + eff (L (Abstract.Unit k)) = k Abstract instance Carrier sig m => Carrier (Abstract.String Abstract :+: sig) (StringC Abstract m) where - eff = StringC . handleSum (eff . handleCoercible) (\case - Abstract.String _ k -> runStringC (k Abstract) - AsString _ k -> runStringC (k "")) + eff (R other) = StringC . eff . handleCoercible $ other + eff (L op) = case op of + Abstract.String _ k -> k Abstract + AsString _ k -> k "" instance Carrier sig m => Carrier (Numeric Abstract :+: sig) (NumericC Abstract m) where - eff = NumericC . handleSum (eff . handleCoercible) (\case - Integer _ k -> runNumericC (k Abstract) - Float _ k -> runNumericC (k Abstract) - Rational _ k -> runNumericC (k Abstract) - LiftNumeric _ _ k -> runNumericC (k Abstract) - LiftNumeric2 _ _ _ k -> runNumericC (k Abstract)) + eff (R other) = NumericC . eff . handleCoercible $ other + eff (L op) = case op of + Integer _ k -> k Abstract + Float _ k -> k Abstract + Rational _ k -> k Abstract + LiftNumeric _ _ k -> k Abstract + LiftNumeric2 _ _ _ k -> k Abstract instance Carrier sig m => Carrier (Bitwise Abstract :+: sig) (BitwiseC Abstract m) where - eff = BitwiseC . handleSum (eff . handleCoercible) (\case - CastToInteger _ k -> runBitwiseC (k Abstract) - LiftBitwise _ _ k -> runBitwiseC (k Abstract) - LiftBitwise2 _ _ _ k -> runBitwiseC (k Abstract) - UnsignedRShift _ _ k -> runBitwiseC (k Abstract)) + eff (R other) = BitwiseC . eff . handleCoercible $ other + eff (L op) = case op of + CastToInteger _ k -> k Abstract + LiftBitwise _ _ k -> k Abstract + LiftBitwise2 _ _ _ k -> k Abstract + UnsignedRShift _ _ k -> k Abstract instance Carrier sig m => Carrier (Object address Abstract :+: sig) (ObjectC address Abstract m) where - eff = ObjectC . handleSum (eff . handleCoercible) (\case - Object _ k -> runObjectC (k Abstract) - ScopedEnvironment _ k -> runObjectC (k Nothing) - Klass _ _ k -> runObjectC (k Abstract)) + eff (R other) = ObjectC . eff . handleCoercible $ other + eff (L op) = case op of + Object _ k -> k Abstract + ScopedEnvironment _ k -> k Nothing + Klass _ _ k -> k Abstract instance Carrier sig m => Carrier (Array Abstract :+: sig) (ArrayC Abstract m) where - eff = ArrayC . handleSum (eff . handleCoercible) (\case - Array _ k -> runArrayC (k Abstract) - AsArray _ k -> runArrayC (k [])) + eff (R other) = ArrayC . eff . handleCoercible $ other + eff (L op) = case op of + Array _ k -> k Abstract + AsArray _ k -> k [] instance Carrier sig m => Carrier (Hash Abstract :+: sig) (HashC Abstract m) where - eff = HashC . handleSum (eff . handleCoercible) (\case - Hash _ k -> runHashC (k Abstract) - KvPair _ _ k -> runHashC (k Abstract)) + eff (R other) = HashC . eff . handleCoercible $ other + eff (L op) = case op of + Hash _ k -> k Abstract + KvPair _ _ k -> k Abstract instance Ord address => ValueRoots address Abstract where @@ -136,7 +138,7 @@ instance AbstractHole Abstract where instance AbstractIntro Abstract where null = Abstract -instance AbstractValue term address Abstract m where +instance Applicative m => AbstractValue term address Abstract m where tuple _ = pure Abstract namespace _ _ = pure Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 39ed9a82c..6202323d4 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -133,6 +133,7 @@ instance ( Member (Reader ModuleInfo) sig Abstract.AsBool (Boolean b) k -> k b Abstract.AsBool other k -> throwBaseError (BoolError other) >>= k +-- PT FIXME: this one is gnarly instance ( Carrier sig m , Member (Abstract.Boolean (Value term address)) sig @@ -140,27 +141,26 @@ instance ( Carrier sig m , Member (Interpose (Resumable (BaseError (UnspecializedError address (Value term address))))) sig ) => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where - eff = WhileC . handleSum (eff . handleCoercible) (\case - Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do - cond' <- Evaluator (runWhileC cond) + -- eff = WhileC . handleSum (eff . handleCoercible) (\case + -- Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do cond' <- Evaluator (runWhileC cond) - -- `interpose` is used to handle 'UnspecializedError's and abort out of the - -- loop, otherwise under concrete semantics we run the risk of the - -- conditional always being true and getting stuck in an infinite loop. + -- -- `interpose` is used to handle 'UnspecializedError's and abort out of the + -- -- loop, otherwise under concrete semantics we run the risk of the + -- -- conditional always being true and getting stuck in an infinite loop. - ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit)))) - (\case - Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) - Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) - >>= runWhileC . k) - where - loop x = catchLoopControl (fix x) $ \case - Break value -> pure value - Abort -> pure Unit - -- FIXME: Figure out how to deal with this. Ruby treats this as the result - -- of the current block iteration, while PHP specifies a breakout level - -- and TypeScript appears to take a label. - Continue _ -> loop x + -- ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit)))) + -- (\case + -- Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) + -- Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) + -- >>= runWhileC . k) + -- where + -- loop x = catchLoopControl (fix x) $ \case + -- Break value -> pure value + -- Abort -> pure Unit + -- -- FIXME: Figure out how to deal with this. Ruby treats this as the result + -- -- of the current block iteration, while PHP specifies a breakout level + -- -- and TypeScript appears to take a label. + -- Continue _ -> loop x instance Carrier sig m @@ -215,7 +215,6 @@ specialize :: ( Member (Reader ModuleInfo) sig , Member (Reader Span) sig , Member (Resumable (BaseError (ValueError term address))) sig , Carrier sig m - , Monad m ) => Either ArithException Number.SomeNumber -> m (Value term address) @@ -272,7 +271,7 @@ instance ( Member (Reader ModuleInfo) sig Abstract.AsArray val k -> throwBaseError (ArrayError val) >>= k instance ( Carrier sig m ) => Carrier (Abstract.Hash (Value term address) :+: sig) (HashC (Value term address) m) where - eff (R other) = ArrayC . eff . handleCoercible $ other + eff (R other) = HashC . eff . handleCoercible $ other eff (L op) = case op of Abstract.Hash t k -> k ((Hash . map (uncurry KVPair)) t) Abstract.KvPair t v k -> k (KVPair t v) @@ -388,13 +387,11 @@ deriving instance (Show address, Show term) => Show (ValueError term address res instance (Show address, Show term) => Show1 (ValueError term address) where liftShowsPrec _ _ = showsPrec -runValueError :: (Carrier sig m, Effect sig) - => Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) m) a +runValueError :: Evaluator term address (Value term address) (ResumableC (BaseError (ValueError term address)) m) a -> Evaluator term address (Value term address) m (Either (SomeError (BaseError (ValueError term address))) a) runValueError = Evaluator . runResumable . runEvaluator -runValueErrorWith :: Carrier sig m - => (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume) +runValueErrorWith :: (forall resume . BaseError (ValueError term address) resume -> Evaluator term address (Value term address) m resume) -> Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) m) a -> Evaluator term address (Value term address) m a runValueErrorWith f = Evaluator . runResumableWith (runEvaluator . f) . runEvaluator diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index fd42659de..727c67b5b 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -87,10 +87,13 @@ instance Ord1 TypeError where instance Show1 TypeError where liftShowsPrec _ _ = showsPrec -runTypeError :: (Carrier sig m, Effect sig) => Evaluator term address value (ResumableC (BaseError TypeError) m) a -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a) +runTypeError :: Evaluator term address value (ResumableC (BaseError TypeError) m) a + -> Evaluator term address value m (Either (SomeError (BaseError TypeError)) a) runTypeError = raiseHandler runResumable -runTypeErrorWith :: Carrier sig m => (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume) -> Evaluator term address value (ResumableWithC (BaseError TypeError) m) a -> Evaluator term address value m a +runTypeErrorWith :: (forall resume . (BaseError TypeError) resume -> Evaluator term address value m resume) + -> Evaluator term address value (ResumableWithC (BaseError TypeError) m) a + -> Evaluator term address value m a runTypeErrorWith f = raiseHandler $ runResumableWith (runEvaluator . f) @@ -98,24 +101,23 @@ throwTypeError :: ( Member (Resumable (BaseError TypeError)) sig , Member (Reader ModuleInfo) sig , Member (Reader Span) sig , Carrier sig m - , Monad m ) => TypeError resume -> m resume throwTypeError = throwBaseError -runTypeMap :: (Carrier sig m, Effect sig) +runTypeMap :: Carrier sig m => Evaluator term address Type (StateC TypeMap m) a -> Evaluator term address Type m a runTypeMap = raiseHandler $ fmap snd . runState emptyTypeMap -runTypes :: (Carrier sig m, Effect sig) +runTypes :: Carrier sig m => Evaluator term address Type (ResumableC (BaseError TypeError) (StateC TypeMap m)) a -> Evaluator term address Type m (Either (SomeError (BaseError TypeError)) a) runTypes = runTypeMap . runTypeError -runTypesWith :: (Carrier sig m, Effect sig) +runTypesWith :: Carrier sig m => (forall resume . (BaseError TypeError) resume -> Evaluator term address Type (StateC TypeMap m) resume) -> Evaluator term address Type (ResumableWithC (BaseError TypeError) (StateC TypeMap @@ -131,7 +133,6 @@ emptyTypeMap = TypeMap Map.empty modifyTypeMap :: ( Member (State TypeMap) sig , Carrier sig m - , Monad m ) => (Map.Map TName Type -> Map.Map TName Type) -> m () @@ -140,7 +141,6 @@ modifyTypeMap f = modify (TypeMap . f . unTypeMap) -- | Prunes substituted type variables prune :: ( Member (State TypeMap) sig , Carrier sig m - , Monad m ) => Type -> m Type @@ -156,7 +156,6 @@ prune ty = pure ty -- function is used in 'substitute' to prevent unification of infinite types occur :: ( Member (State TypeMap) sig , Carrier sig m - , Monad m ) => TName -> Type @@ -188,7 +187,6 @@ substitute :: ( Member (Reader ModuleInfo) sig , Member (Resumable (BaseError TypeError)) sig , Member (State TypeMap) sig , Carrier sig m - , Monad m ) => TName -> Type @@ -207,7 +205,6 @@ unify :: ( Member (Reader ModuleInfo) sig , Member (Resumable (BaseError TypeError)) sig , Member (State TypeMap) sig , Carrier sig m - , Monad m ) => Type -> Type @@ -295,7 +292,6 @@ instance ( Member (Reader ModuleInfo) sig , Member (State TypeMap) sig , Carrier sig m , Alternative m - , Monad m ) => Carrier (Abstract.Boolean Type :+: sig) (BooleanC Type m) where eff (R other) = BooleanC . eff . handleCoercible $ other @@ -307,7 +303,6 @@ instance ( Member (Reader ModuleInfo) sig instance ( Member (Abstract.Boolean Type) sig , Carrier sig m , Alternative m - , Monad m ) => Carrier (Abstract.While Type :+: sig) (WhileC Type m) where eff (R other) = WhileC . eff . handleCoercible $ other @@ -327,7 +322,6 @@ instance ( Member (Reader ModuleInfo) sig , Member (State TypeMap) sig , Carrier sig m , Alternative m - , Monad m ) => Carrier (Abstract.String Type :+: sig) (StringC Type m) where eff (R other) = StringC . eff . handleCoercible $ other diff --git a/src/Data/Project.hs b/src/Data/Project.hs index a68c6abb2..5ec5678a4 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -58,7 +58,7 @@ newtype ProjectException = FileNotFound FilePath deriving (Show, Eq, Typeable, Exception) -readFile :: (Member (Error SomeException) sig, Applicative m, Carrier sig m) +readFile :: (Member (Error SomeException) sig, Carrier sig m) => Project -> File -> m (Maybe Blob) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 1d5e3516c..70cc5fafd 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -37,8 +37,7 @@ diffTermPair = these Diff.deleting Diff.inserting diffTerms -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations. -runDiff :: (Alternative m, Carrier sig m, Diffable syntax, Eq1 syntax, Member NonDet sig, Monad m, Traversable syntax) - => Algorithm +runDiff :: Algorithm (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 43479ea5d..3180f401f 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -65,7 +65,6 @@ instance (ConstructorName syntax, Foldable syntax) => , Member Fresh sig , Member (Reader (Graph TermVertex)) sig , Carrier sig m - , Monad m ) => TermF syntax Location (m (Graph TermVertex)) -> m (Graph TermVertex) @@ -97,7 +96,6 @@ instance (ConstructorName syntax, Foldable syntax) => , Member Fresh sig , Member (Reader (Graph DiffTreeVertex)) sig , Carrier sig m - , Monad m ) => f (m (Graph DiffTreeVertex)) -> DiffTreeVertexDiffTerm -> m (Graph DiffTreeVertex) diffAlgebra syntax a = do i <- fresh diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index 759579674..f38d222d0 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -43,10 +43,10 @@ type DomainC term address value m -- | Evaluate a list of modules with the prelude for the passed language available, and applying the passed function to every module. evaluate :: ( Carrier outerSig outer , derefSig ~ (Deref value :+: allocatorSig) - , derefC ~ (DerefC address value (Eff allocatorC)) + , derefC ~ (DerefC address value allocatorC) , Carrier derefSig derefC , allocatorSig ~ (Allocator address :+: Reader ModuleInfo :+: outerSig) - , allocatorC ~ (AllocatorC address (Eff (ReaderC ModuleInfo (Eff outer)))) + , allocatorC ~ (AllocatorC address (ReaderC ModuleInfo outer)) , Carrier allocatorSig allocatorC , Effect outerSig , Member Fresh outerSig From 79ae5903768f0eac2fa0d520d4a7ff0a0f64f59a Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 6 Mar 2019 10:12:10 -0500 Subject: [PATCH 21/32] compiles --- src/Analysis/Abstract/Graph.hs | 51 +++++---- src/Control/Abstract/PythonPackage.hs | 7 +- src/Control/Abstract/Value.hs | 16 +-- src/Semantic/Analysis.hs | 31 ++---- src/Semantic/Distribute.hs | 14 +-- src/Semantic/Graph.hs | 69 ++++++------ src/Semantic/REPL.hs | 27 ++--- src/Semantic/Resolution.hs | 21 ++-- src/Semantic/Task.hs | 81 ++++++-------- src/Semantic/Task/Files.hs | 30 +++--- src/Semantic/Telemetry.hs | 23 ++-- src/Semantic/Timeout.hs | 3 +- src/Semantic/Util.hs | 137 ++++++++++-------------- test/Control/Abstract/Evaluator/Spec.hs | 48 ++++----- test/SpecHelpers.hs | 26 ++--- 15 files changed, 265 insertions(+), 319 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 8ae0b6271..788b9998c 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Graph ( Graph(..) , ControlFlowVertex(..) @@ -106,20 +106,18 @@ graphingPackages :: ( Member (Reader PackageInfo) sig , Member (State (Graph ControlFlowVertex)) sig , Member (Reader ControlFlowVertex) sig , Carrier sig m - , Monad m ) => Open (Module term -> m a) graphingPackages recur m = let v = moduleVertex (moduleInfo m) in packageInclusion v *> local (const v) (recur m) -- | Add vertices to the graph for imported modules. -graphingModules :: ( Member (Modules address value) sig - , Member (Reader ModuleInfo) sig +graphingModules :: ( Member (Reader ModuleInfo) sig , Member (State (Graph ControlFlowVertex)) sig , Member (Reader ControlFlowVertex) sig , Carrier sig m ) - => (Module body -> Evaluator term address value (EavesdropC address value (Eff m)) a) + => (Module body -> Evaluator term address value (EavesdropC address value m) a) -> (Module body -> Evaluator term address value m a) graphingModules recur m = do let v = moduleVertex (moduleInfo m) @@ -135,12 +133,11 @@ graphingModules recur m = do in moduleInclusion (moduleVertex (ModuleInfo path')) -- | Add vertices to the graph for imported modules. -graphingModuleInfo :: ( Member (Modules address value) sig - , Member (Reader ModuleInfo) sig +graphingModuleInfo :: ( Member (Reader ModuleInfo) sig , Member (State (Graph ModuleInfo)) sig , Carrier sig m ) - => (Module body -> Evaluator term address value (EavesdropC address value (Eff m)) a) + => (Module body -> Evaluator term address value (EavesdropC address value m) a) -> (Module body -> Evaluator term address value m a) graphingModuleInfo recur m = do appendGraph (vertex (moduleInfo m)) @@ -149,28 +146,32 @@ graphingModuleInfo recur m = do Lookup path _ -> currentModule >>= appendGraph . (`connect` vertex (ModuleInfo path)) . vertex _ -> pure () -eavesdrop :: (Carrier sig m, Member (Modules address value) sig) - => Evaluator term address value (EavesdropC address value (Eff m)) a - -> (forall x . Modules address value (Eff m) (Eff m x) -> Evaluator term address value m ()) +eavesdrop :: Evaluator term address value (EavesdropC address value m) a + -> (forall x . Modules address value m (m x) -> Evaluator term address value m ()) -> Evaluator term address value m a -eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f) . interpret) m +eavesdrop m f = raiseHandler (runHandler (Handler (runEvaluator . f))) m -newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address value m (m x) -> m ()) -> m a) +newtype Handler address value m = Handler (forall x . Modules address value m (m x) -> m ()) -runEavesdropC :: (forall x . Modules address value m (m x) -> m ()) -> EavesdropC address value m a -> m a -runEavesdropC f (EavesdropC m) = m f +newtype EavesdropC address value m a = EavesdropC + { runEavesdropC :: ReaderC (Handler address value m) m a + } deriving (Alternative, Applicative, Functor, Monad) + +runHandler :: Handler address value m -> EavesdropC address value m a -> m a +runHandler h = runReader h . runEavesdropC instance (Carrier sig m, Member (Modules address value) sig, Applicative m) => Carrier sig (EavesdropC address value m) where - ret a = EavesdropC (const (ret a)) - eff op - | Just eff <- prj op = EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff') - | otherwise = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op)) + -- eff (R other) = _ other + -- eff (L op) = do + -- handler <- EavesdropC ask + -- case prj op of + -- Just e -> runHandler handler e *> send e + -- Nothing -> undefined -- | Add an edge from the current package to the passed vertex. packageInclusion :: ( Member (Reader PackageInfo) sig , Member (State (Graph ControlFlowVertex)) sig , Carrier sig m - , Monad m ) => ControlFlowVertex -> m () @@ -182,7 +183,6 @@ packageInclusion v = do moduleInclusion :: ( Member (Reader ModuleInfo) sig , Member (State (Graph ControlFlowVertex)) sig , Carrier sig m - , Monad m ) => ControlFlowVertex -> m () @@ -194,7 +194,6 @@ moduleInclusion v = do variableDefinition :: ( Member (State (Graph ControlFlowVertex)) sig , Member (Reader ControlFlowVertex) sig , Carrier sig m - , Monad m ) => ControlFlowVertex -> m () @@ -206,9 +205,9 @@ appendGraph :: (Member (State (Graph v)) sig, Carrier sig m) => Graph v -> m () appendGraph = modify . (<>) -graphing :: (Carrier sig m, Effect sig) - => Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex) (Eff - (StateC (Graph ControlFlowVertex) (Eff - m)))) result +graphing :: Carrier sig m + => Evaluator term address value (StateC (Map (Slot address) ControlFlowVertex) + (StateC (Graph ControlFlowVertex) + m)) result -> Evaluator term address value m (Graph ControlFlowVertex, result) graphing = raiseHandler $ runState mempty . fmap snd . runState lowerBound diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index 1e10f188b..c7119e71a 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -14,12 +14,7 @@ import Prologue data Strategy = Unknown | Packages [Text] | FindPackages [Text] deriving (Show, Eq) -runPythonPackaging :: ( Carrier sig m - , Member (Abstract.String (Value term address)) sig - , Member (Abstract.Array (Value term address)) sig - , Member (State Strategy) sig - , Member (Function term address (Value term address)) sig) - => Evaluator term address (Value term address) (PythonPackagingC term address m) a +runPythonPackaging :: Evaluator term address (Value term address) (PythonPackagingC term address m) a -> Evaluator term address (Value term address) m a runPythonPackaging = raiseHandler runPythonPackagingC diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d4b088c52..9ec597bcf 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -144,7 +144,7 @@ runFunction :: (term -> Evaluator term address value (FunctionC term address val runFunction eval = raiseHandler (runReader (runEvaluator . eval) . runFunctionC) newtype FunctionC term address value m a = FunctionC { runFunctionC :: ReaderC (term -> FunctionC term address value m value) m a } - deriving newtype (Applicative, Functor, Monad) + deriving newtype (Alternative, Applicative, Functor, Monad) -- | Construct a boolean value in the abstract domain. boolean :: (Member (Boolean value) sig, Carrier sig m) => Bool -> m value @@ -252,7 +252,7 @@ runUnit = raiseHandler $ runUnitC newtype UnitC value m a = UnitC { runUnitC :: m a } deriving stock Functor - deriving newtype (Applicative, Monad) + deriving newtype (Alternative, Applicative, Monad) -- | Construct a String value in the abstract domain. string :: (Member (String value) sig, Carrier sig m) => Text -> m value @@ -277,7 +277,7 @@ instance Effect (String value) where newtype StringC value m a = StringC { runStringC :: m a } deriving stock Functor - deriving newtype (Applicative, Monad) + deriving newtype (Alternative, Applicative, Monad) runString :: Evaluator term address value (StringC value m) a -> Evaluator term address value m a @@ -331,7 +331,7 @@ instance Effect (Numeric value) where newtype NumericC value m a = NumericC { runNumericC :: m a } deriving stock Functor - deriving newtype (Applicative, Monad) + deriving newtype (Alternative, Applicative, Monad) runNumeric :: Evaluator term address value (NumericC value m) a -> Evaluator term address value m a @@ -385,7 +385,7 @@ runBitwise = raiseHandler $ runBitwiseC newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } deriving stock Functor - deriving newtype (Applicative, Monad) + deriving newtype (Alternative, Applicative, Monad) object :: (Member (Object address value) sig, Carrier sig m) => address -> m value object address = send (Object address pure) @@ -415,7 +415,7 @@ instance Effect (Object address value) where newtype ObjectC address value m a = ObjectC { runObjectC :: m a } deriving stock Functor - deriving newtype (Applicative, Monad) + deriving newtype (Alternative, Applicative, Monad) runObject :: Evaluator term address value (ObjectC address value m) a -> Evaluator term address value m a @@ -442,7 +442,7 @@ instance Effect (Array value) where newtype ArrayC value m a = ArrayC { runArrayC :: m a } deriving stock Functor - deriving newtype (Applicative, Monad) + deriving newtype (Alternative, Applicative, Monad) runArray :: Evaluator term address value (ArrayC value m) a -> Evaluator term address value m a @@ -470,7 +470,7 @@ instance Effect (Hash value) where newtype HashC value m a = HashC { runHashC :: m a } deriving stock Functor - deriving newtype (Applicative, Monad) + deriving newtype (Alternative, Applicative, Monad) runHash :: Evaluator term address value (HashC value m) a -> Evaluator term address value m a diff --git a/src/Semantic/Analysis.hs b/src/Semantic/Analysis.hs index f38d222d0..5e577ad35 100644 --- a/src/Semantic/Analysis.hs +++ b/src/Semantic/Analysis.hs @@ -86,35 +86,25 @@ evaluate lang runModule modules = do . runModule runDomainEffects :: ( AbstractValue term address value (DomainC term address value m) - , Carrier sig m - , unitC ~ UnitC value (Eff (InterposeC (Resumable (BaseError (UnspecializedError address value))) (Eff m))) + , unitC ~ UnitC value (InterposeC (Resumable (BaseError (UnspecializedError address value))) m) , unitSig ~ (Unit value :+: Interpose (Resumable (BaseError (UnspecializedError address value))) :+: sig) - , Carrier unitSig unitC - , hashC ~ HashC value (Eff unitC) + , hashC ~ HashC value unitC , hashSig ~ (Abstract.Hash value :+: unitSig) - , Carrier hashSig hashC - , arrayC ~ ArrayC value (Eff hashC) + , arrayC ~ ArrayC value hashC , arraySig ~ (Abstract.Array value :+: hashSig) - , Carrier arraySig arrayC - , objectC ~ ObjectC address value (Eff arrayC) + , objectC ~ ObjectC address value arrayC , objectSig ~ (Abstract.Object address value :+: arraySig) - , Carrier objectSig objectC - , bitwiseC ~ BitwiseC value (Eff objectC) + , bitwiseC ~ BitwiseC value objectC , bitwiseSig ~ (Abstract.Bitwise value :+: objectSig) - , Carrier bitwiseSig bitwiseC - , numericC ~ NumericC value (Eff bitwiseC) + , numericC ~ NumericC value bitwiseC , numericSig ~ (Abstract.Numeric value :+: bitwiseSig) - , Carrier numericSig numericC - , stringC ~ StringC value (Eff numericC) + , stringC ~ StringC value numericC , stringSig ~ (Abstract.String value :+: numericSig) - , Carrier stringSig stringC - , booleanC ~ BooleanC value (Eff stringC) + , booleanC ~ BooleanC value stringC , booleanSig ~ (Boolean value :+: stringSig) - , Carrier booleanSig booleanC - , whileC ~ WhileC value (Eff booleanC) + , whileC ~ WhileC value booleanC , whileSig ~ (While value :+: booleanSig) - , Carrier whileSig whileC - , functionC ~ FunctionC term address value (Eff whileC) + , functionC ~ FunctionC term address value whileC , functionSig ~ (Function term address value :+: whileSig) , Carrier functionSig functionC , HasPrelude lang @@ -128,7 +118,6 @@ runDomainEffects :: ( AbstractValue term address value (DomainC term address val , Member (Resumable (BaseError (AddressError address value))) sig , Member (Resumable (BaseError (HeapError address))) sig , Member (Resumable (BaseError (ScopeError address))) sig - , Member (Resumable (BaseError (UnspecializedError address value))) sig , Member (State (Heap address address value)) sig , Member (State (ScopeGraph address)) sig , Member Trace sig diff --git a/src/Semantic/Distribute.hs b/src/Semantic/Distribute.hs index a3f8f2ae8..bc8609d46 100644 --- a/src/Semantic/Distribute.hs +++ b/src/Semantic/Distribute.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-} module Semantic.Distribute ( distribute , distributeFor @@ -18,19 +18,19 @@ import Prologue -- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results. -- -- This is a concurrent analogue of 'sequenceA'. -distribute :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t (m output) -> m (t output) -distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute ret) +distribute :: (Member Distribute sig, Traversable t, Carrier sig m) => t (m output) -> m (t output) +distribute = fmap (withStrategy (parTraversable rseq)) <$> traverse (send . flip Distribute pure) -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results. -- -- This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped). -distributeFor :: (Member Distribute sig, Traversable t, Carrier sig m, Applicative m) => t a -> (a -> m output) -> m (t output) +distributeFor :: (Member Distribute sig, Traversable t, Carrier sig m) => t a -> (a -> m output) -> m (t output) distributeFor inputs toTask = distribute (fmap toTask inputs) -- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), combining the results 'Monoid'ally into a final value. -- -- This is a concurrent analogue of 'foldMap'. -distributeFoldMap :: (Member Distribute sig, Monoid output, Traversable t, Carrier sig m, Applicative m) => (a -> m output) -> t a -> m output +distributeFoldMap :: (Member Distribute sig, Monoid output, Traversable t, Carrier sig m) => (a -> m output) -> t a -> m output distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) @@ -52,8 +52,8 @@ runDistribute :: DistributeC (LiftC IO) a -> LiftC IO a runDistribute = runDistributeC newtype DistributeC m a = DistributeC { runDistributeC :: m a } - deriving (Functor, Applicative, Monad) + deriving (Functor, Applicative, Monad, MonadIO) instance Carrier (Distribute :+: Lift IO) (DistributeC (LiftC IO)) where - eff (L (Distribute task k)) = liftIO (Async.runConcurrently (Async.Concurrently (runM task))) >>= k + eff (L (Distribute task k)) = liftIO (Async.runConcurrently (Async.Concurrently (runM . runDistributeC $ task))) >>= k eff (R other) = DistributeC (eff (handleCoercible other)) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index e75fab4ec..f605003b3 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -82,7 +82,7 @@ runGraph :: ( Member Distribute sig => GraphType -> Bool -> Project - -> Eff m (Graph ControlFlowVertex) + -> m (Graph ControlFlowVertex) runGraph ImportGraph _ project | SomeAnalysisParser parser (lang' :: Proxy lang) <- someAnalysisParser (Proxy :: Proxy AnalysisClasses) (projectLanguage project) = do let parse = if projectLanguage project == Language.Python then parsePythonPackage parser else fmap (fmap snd) . parsePackage parser @@ -112,7 +112,7 @@ runCallGraph :: ( VertexDeclarationWithStrategy (VertexDeclarationStrategy synta -> Bool -> [Module term] -> Package term - -> Eff m (Graph ControlFlowVertex) + -> m (Graph ControlFlowVertex) runCallGraph lang includePackages modules package = fmap (simplify . fst) . runEvaluator @@ -140,8 +140,7 @@ runCallGraph lang includePackages modules package perModule = (if includePackages then graphingPackages else id) . convergingModules . graphingModules $ runDomainEffects perTerm -runModuleTable :: Carrier sig m - => Evaluator term address value (ReaderC (ModuleTable (Module (ModuleResult address value))) (Eff m)) a +runModuleTable :: Evaluator term address value (ReaderC (ModuleTable (Module (ModuleResult address value))) m) a -> Evaluator term address value m a runModuleTable = raiseHandler $ runReader lowerBound @@ -159,7 +158,7 @@ runImportGraphToModuleInfos :: ( Declarations term ) => Proxy lang -> Package term - -> Eff m (Graph ControlFlowVertex) + -> m (Graph ControlFlowVertex) runImportGraphToModuleInfos lang (package :: Package term) = runImportGraph lang package allModuleInfos where allModuleInfos info = vertex (maybe (unknownModuleVertex info) (moduleVertex . moduleInfo) (ModuleTable.lookup (modulePath info) (packageModules package))) @@ -177,7 +176,7 @@ runImportGraphToModules :: ( Declarations term ) => Proxy lang -> Package term - -> Eff m (Graph (Module term)) + -> m (Graph (Module term)) runImportGraphToModules lang (package :: Package term) = runImportGraph lang package resolveOrLowerBound where resolveOrLowerBound info = maybe lowerBound vertex (ModuleTable.lookup (modulePath info) (packageModules package)) @@ -196,7 +195,7 @@ runImportGraph :: ( AccessControls term => Proxy lang -> Package term -> (ModuleInfo -> Graph vertex) - -> Eff m (Graph vertex) + -> m (Graph vertex) runImportGraph lang (package :: Package term) f = fmap (fst >=> f) . runEvaluator @_ @_ @(Value _ (Hole (Maybe Name) Precise)) @@ -220,14 +219,13 @@ runImportGraph lang (package :: Package term) f . runAllocator $ evaluate lang (graphingModuleInfo (runDomainEffects (evalTerm id))) (snd <$> ModuleTable.toPairs (packageModules package)) -runHeap :: (Carrier sig m, Effect sig) - => Evaluator term address value (StateC (Heap address address value) (Eff m)) a +runHeap :: Evaluator term address value (StateC (Heap address address value) m) a -> Evaluator term address value m (Heap address address value, a) runHeap = raiseHandler (runState lowerBound) -runScopeGraph :: (Carrier sig m, Effect sig, Ord address) - => Evaluator term address value (StateC (ScopeGraph address) (Eff m)) a - -> Evaluator term address value m (ScopeGraph address, a) +runScopeGraph :: Ord address + => Evaluator term address value (StateC (ScopeGraph address) m) a + -> Evaluator term address value m (ScopeGraph address, a) runScopeGraph = raiseHandler (runState lowerBound) -- | Parse a list of files into a 'Package'. @@ -267,7 +265,7 @@ parsePythonPackage :: forall syntax sig m term. ) => Parser term -- ^ A parser. -> Project -- ^ Project to parse into a package. - -> Eff m (Package term) + -> m (Package term) parsePythonPackage parser project = do let runAnalysis = runEvaluator @_ @_ @(Value term (Hole (Maybe Name) Precise)) . raiseHandler (runState PythonPackage.Unknown) @@ -347,19 +345,20 @@ withTermSpans recur term = let resumingResolutionError :: ( Member Trace sig , Carrier sig m ) - => Evaluator term address value (ResumableWithC (BaseError ResolutionError) (Eff - m)) a + => Evaluator term address value (ResumableWithC (BaseError ResolutionError) m) a -> Evaluator term address value m a -resumingResolutionError = runResolutionErrorWith (\ baseError -> traceError "ResolutionError" baseError *> case baseErrorException baseError of - NotFoundError nameToResolve _ _ -> pure nameToResolve - GoImportError pathToResolve -> pure [pathToResolve]) +resumingResolutionError = runResolutionErrorWith $ \ baseError -> do + traceError "ResolutionError" baseError + case baseErrorException baseError of + NotFoundError nameToResolve _ _ -> pure nameToResolve + GoImportError pathToResolve -> pure [pathToResolve] resumingLoadError :: ( Carrier sig m , Member Trace sig , AbstractHole value , AbstractHole address ) - => Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) (Eff m)) a + => Evaluator term address value (ResumableWithC (BaseError (LoadError address value)) m) a -> Evaluator term address value m a resumingLoadError = runLoadErrorWith (\ baseError -> traceError "LoadError" baseError *> case baseErrorException baseError of ModuleNotFoundError _ -> pure ((hole, hole), hole)) @@ -372,8 +371,7 @@ resumingEvalError :: ( Carrier sig m , AbstractHole address , AbstractHole value ) - => Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) (Eff - m)) a + => Evaluator term address value (ResumableWithC (BaseError (EvalError term address value)) m) a -> Evaluator term address value m a resumingEvalError = runEvalErrorWith (\ baseError -> traceError "EvalError" baseError *> case baseErrorException baseError of AccessControlError{} -> pure hole @@ -393,8 +391,7 @@ resumingUnspecialized :: ( AbstractHole address , Carrier sig m , Member Trace sig ) - => Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) (Eff - m)) a + => Evaluator term address value (ResumableWithC (BaseError (UnspecializedError address value)) m) a -> Evaluator term address value m a resumingUnspecialized = runUnspecializedWith (\ baseError -> traceError "UnspecializedError" baseError *> case baseErrorException baseError of UnspecializedError _ -> pure hole @@ -405,20 +402,20 @@ resumingAddressError :: ( AbstractHole value , Member Trace sig , Show address ) - => Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) (Eff - m)) a + => Evaluator term address value (ResumableWithC (BaseError (AddressError address value)) m) a -> Evaluator term address value m a -resumingAddressError = runAddressErrorWith $ \ baseError -> traceError "AddressError" baseError *> case baseErrorException baseError of - UnallocatedSlot _ -> pure lowerBound - UninitializedSlot _ -> pure hole +resumingAddressError = runAddressErrorWith $ \ baseError -> do + traceError "AddressError" baseError + case baseErrorException baseError of + UnallocatedSlot _ -> pure lowerBound + UninitializedSlot _ -> pure hole resumingValueError :: ( Carrier sig m , Member Trace sig , Show address , Show term ) - => Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) (Eff - m)) a + => Evaluator term address (Value term address) (ResumableWithC (BaseError (ValueError term address)) m) a -> Evaluator term address (Value term address) m a resumingValueError = runValueErrorWith (\ baseError -> traceError "ValueError" baseError *> case baseErrorException baseError of CallError{} -> pure hole @@ -440,7 +437,7 @@ resumingHeapError :: ( Carrier sig m , Member Trace sig , Show address ) - => Evaluator term address value (ResumableWithC (BaseError (HeapError address)) (Eff m)) a + => Evaluator term address value (ResumableWithC (BaseError (HeapError address)) m) a -> Evaluator term address value m a resumingHeapError = runHeapErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of CurrentFrameError -> pure hole @@ -458,7 +455,7 @@ resumingScopeError :: ( Carrier sig m , AbstractHole (Info address) , AbstractHole address ) - => Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) (Eff m)) a + => Evaluator term address value (ResumableWithC (BaseError (ScopeError address)) m) a -> Evaluator term address value m a resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" baseError *> case baseErrorException baseError of ScopeError _ _ -> pure hole @@ -470,13 +467,13 @@ resumingScopeError = runScopeErrorWith (\ baseError -> traceError "ScopeError" b DeclarationByNameError _ -> pure hole) resumingTypeError :: ( Carrier sig m - , Member NonDet sig , Member Trace sig , Effect sig + , Alternative m ) - => Evaluator term address Type (ResumableWithC (BaseError TypeError) (Eff - (StateC TypeMap (Eff - m)))) a + => Evaluator term address Type (ResumableWithC (BaseError TypeError) + (StateC TypeMap + m)) a -> Evaluator term address Type m a resumingTypeError = runTypesWith (\ baseError -> traceError "TypeError" baseError *> case baseErrorException baseError of UnificationError l r -> pure l <|> pure r diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 4eaf3b1bc..dadcb9c86 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.REPL ( rubyREPL @@ -100,20 +100,23 @@ repl proxy parser paths = -- TODO: drive the flow from within the REPL instead of from without -runTelemetryIgnoringStat :: (Carrier sig m, MonadIO m) => LogOptions -> Eff (TelemetryIgnoringStatC m) a -> m a -runTelemetryIgnoringStat logOptions = flip runTelemetryIgnoringStatC logOptions . interpret +runTelemetryIgnoringStat :: (Carrier sig m, MonadIO m) => LogOptions -> TelemetryIgnoringStatC m a -> m a +runTelemetryIgnoringStat logOptions = runReader logOptions . runTelemetryIgnoringStatC -newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: LogOptions -> m a } +newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: ReaderC LogOptions m a } + deriving (Applicative, Functor, Monad, MonadIO) instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryIgnoringStatC m) where - ret = TelemetryIgnoringStatC . const . ret - eff op = TelemetryIgnoringStatC (\ logOptions -> handleSum (eff . handleReader logOptions runTelemetryIgnoringStatC) (\case - WriteStat _ k -> runTelemetryIgnoringStatC k logOptions - WriteLog level message pairs k -> do - time <- liftIO Time.getCurrentTime - zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time) - writeLogMessage logOptions (Message level message pairs zonedTime) - runTelemetryIgnoringStatC k logOptions) op) + eff (R other) = TelemetryIgnoringStatC . eff . R . handleCoercible $ other + eff (L op) = do + logOptions <- TelemetryIgnoringStatC ask + case op of + WriteStat _ k -> k + WriteLog level message pairs k -> do + time <- liftIO Time.getCurrentTime + zonedTime <- liftIO (LocalTime.utcToLocalZonedTime time) + writeLogMessage logOptions (Message level message pairs zonedTime) + k step :: ( Member (Error SomeException) sig , Member REPL sig diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 1a67c0f21..6fd11904a 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.Resolution ( Resolution (..) , nodeJSResolutionMap @@ -41,9 +41,9 @@ nodeJSResolutionMap rootDir prop excludeDirs = do resolutionMap :: (Member Resolution sig, Carrier sig m) => Project -> m (Map FilePath FilePath) resolutionMap Project{..} = case projectLanguage of - TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs ret) - JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs ret) - _ -> send (NoResolution ret) + TypeScript -> send (NodeJSResolution projectRootDir "types" projectExcludeDirs pure) + JavaScript -> send (NodeJSResolution projectRootDir "main" projectExcludeDirs pure) + _ -> send (NoResolution pure) data Resolution (m :: * -> *) k = NodeJSResolution FilePath Text [FilePath] (Map FilePath FilePath -> k) @@ -57,13 +57,14 @@ instance Effect Resolution where handle state handler (NodeJSResolution path key paths k) = NodeJSResolution path key paths (handler . (<$ state) . k) handle state handler (NoResolution k) = NoResolution (handler . (<$ state) . k) -runResolution :: (Member Files sig, Carrier sig m) => Eff (ResolutionC m) a -> m a -runResolution = runResolutionC . interpret +runResolution :: ResolutionC m a -> m a +runResolution = runResolutionC newtype ResolutionC m a = ResolutionC { runResolutionC :: m a } + deriving (Applicative, Functor, Monad, MonadIO) instance (Member Files sig, Carrier sig m) => Carrier (Resolution :+: sig) (ResolutionC m) where - ret = ResolutionC . ret - eff = ResolutionC . handleSum (eff . handleCoercible) (\case - NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= runResolutionC . k - NoResolution k -> runResolutionC (k Map.empty)) + eff (R other) = ResolutionC . eff . handleCoercible $ other + eff (L op) = case op of + NodeJSResolution dir prop excludeDirs k -> nodeJSResolutionMap dir prop excludeDirs >>= k + NoResolution k -> k Map.empty diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 3ad15c3ad..0899b96bd 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, KindSignatures, LambdaCase, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Semantic.Task ( Task , TaskEff @@ -47,7 +47,6 @@ module Semantic.Task , ParserCancelled(..) -- * Re-exports , Distribute -, Eff , Error , Lift , throwError @@ -95,17 +94,17 @@ import Serializing.Format hiding (Options) -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap' type TaskEff - = Eff (TaskC - ( Eff (ResolutionC - ( Eff (Files.FilesC - ( Eff (ReaderC TaskSession - ( Eff (TraceInTelemetryC - ( Eff (TelemetryC - ( Eff (ErrorC SomeException - ( Eff (TimeoutC - ( Eff (ResourceC - ( Eff (DistributeC - ( Eff (LiftC IO))))))))))))))))))))) + = TaskC + ( ResolutionC + ( Files.FilesC + ( ReaderC TaskSession + ( TraceInTelemetryC + ( TelemetryC + ( ErrorC SomeException + ( TimeoutC + ( ResourceC + ( DistributeC + ( LiftC IO)))))))))) -- | A function to render terms or diffs. type Renderer i o = i -> o @@ -115,40 +114,40 @@ parse :: (Member Task sig, Carrier sig m) => Parser term -> Blob -> m term -parse parser blob = send (Parse parser blob ret) +parse parser blob = send (Parse parser blob pure) -- | A task running some 'Analysis.Evaluator' to completion. analyze :: (Member Task sig, Carrier sig m) => (Analysis.Evaluator term address value m a -> result) -> Analysis.Evaluator term address value m a -> m result -analyze interpret analysis = send (Analyze interpret analysis ret) +analyze interpret analysis = send (Analyze interpret analysis pure) -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function. decorate :: (Functor f, Member Task sig, Carrier sig m) => RAlgebra (TermF f Location) (Term f Location) field -> Term f Location -> m (Term f field) -decorate algebra term = send (Decorate algebra term ret) +decorate algebra term = send (Decorate algebra term pure) -- | A task which diffs a pair of terms using the supplied 'Differ' function. diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task sig, Carrier sig m) => These (Term syntax ann) (Term syntax ann) -> m (Diff syntax ann ann) -diff terms = send (Semantic.Task.Diff terms ret) +diff terms = send (Semantic.Task.Diff terms pure) -- | A task which renders some input using the supplied 'Renderer' function. render :: (Member Task sig, Carrier sig m) => Renderer input output -> input -> m output -render renderer input = send (Render renderer input ret) +render renderer input = send (Render renderer input pure) serialize :: (Member Task sig, Carrier sig m) => Format input -> input -> m Builder -serialize format input = send (Serialize format input ret) +serialize format input = send (Serialize format input pure) data TaskSession = TaskSession @@ -191,18 +190,16 @@ withOptions options with = do config <- defaultConfig options withTelemetry config (\ (TelemetryQueues logger statter _) -> with config logger statter) -runTraceInTelemetry :: (Member Telemetry sig, Carrier sig m) - => Eff (TraceInTelemetryC m) a +runTraceInTelemetry :: TraceInTelemetryC m a -> m a -runTraceInTelemetry = runTraceInTelemetryC . interpret +runTraceInTelemetry = runTraceInTelemetryC newtype TraceInTelemetryC m a = TraceInTelemetryC { runTraceInTelemetryC :: m a } + deriving (Applicative, Functor, Monad, MonadIO) instance (Member Telemetry sig, Carrier sig m) => Carrier (Trace :+: sig) (TraceInTelemetryC m) where - ret = TraceInTelemetryC . ret - eff = TraceInTelemetryC . handleSum - (eff . handleCoercible) - (\ (Trace str k) -> writeLog Debug str [] >> runTraceInTelemetryC k) + eff (R other) = TraceInTelemetryC . eff . handleCoercible $ other + eff (L (Trace str k)) = writeLog Debug str [] >> k -- | An effect describing high-level tasks to be performed. @@ -228,33 +225,23 @@ instance Effect Task where handle state handler (Serialize format input k) = Serialize format input (handler . (<$ state) . k) -- | Run a 'Task' effect by performing the actions in 'IO'. -runTaskF :: ( Member (Error SomeException) sig - , Member (Lift IO) sig - , Member (Reader TaskSession) sig - , Member Resource sig - , Member Telemetry sig - , Member Timeout sig - , Member Trace sig - , Carrier sig m - , MonadIO m - ) - => Eff (TaskC m) a - -> m a -runTaskF = runTaskC . interpret +runTaskF :: TaskC m a -> m a +runTaskF = runTaskC newtype TaskC m a = TaskC { runTaskC :: m a } + deriving (Applicative, Functor, Monad, MonadIO) instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader TaskSession) sig, Member Resource sig, Member Telemetry sig, Member Timeout sig, Member Trace sig, Carrier sig m, MonadIO m) => Carrier (Task :+: sig) (TaskC m) where - ret = TaskC . ret - eff = TaskC . handleSum (eff . handleCoercible) (\case - Parse parser blob k -> runParser blob parser >>= runTaskC . k - Analyze interpret analysis k -> runTaskC (k (interpret analysis)) - Decorate algebra term k -> runTaskC (k (decoratorWithAlgebra algebra term)) - Semantic.Task.Diff terms k -> runTaskC (k (diffTermPair terms)) - Render renderer input k -> runTaskC (k (renderer input)) + eff (R other) = TaskC . eff . handleCoercible $ other + eff (L op) = case op of + Parse parser blob k -> runParser blob parser >>= k + Analyze interpret analysis k -> k . interpret $ analysis + Decorate algebra term k -> k (decoratorWithAlgebra algebra term) + Semantic.Task.Diff terms k -> k (diffTermPair terms) + Render renderer input k -> k (renderer input) Serialize format input k -> do formatStyle <- asks (bool Plain Colourful . configIsTerminal . config) - runTaskC (k (runSerialize formatStyle format input))) + k (runSerialize formatStyle format input) -- | Log an 'Error.Error' at the specified 'Level'. diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index 5203d411d..eb392b413 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, GADTs, LambdaCase, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, LambdaCase, KindSignatures, TypeOperators, UndecidableInstances #-} module Semantic.Task.Files ( Files @@ -59,11 +59,11 @@ instance Effect Files where handle state handler (Write destination builder k) = Write destination builder (handler (k <$ state)) -- | Run a 'Files' effect in 'IO'. -runFiles :: (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => FilesC m a -> m a +runFiles :: FilesC m a -> m a runFiles = runFilesC newtype FilesC m a = FilesC { runFilesC :: m a } - deriving (Functor, Applicative, Monad) + deriving (Functor, Applicative, Monad, MonadIO) instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier (Files :+: sig) (FilesC m) where eff (L op) = case op of @@ -73,33 +73,33 @@ instance (Member (Error SomeException) sig, MonadIO m, Carrier sig m) => Carrier Read (FromPairHandle handle) k -> (readBlobPairsFromHandle handle `catchIO` (throwError . toException @SomeException)) >>= k ReadProject rootDir dir language excludeDirs k -> (readProjectFromPaths rootDir dir language excludeDirs `catchIO` (throwError . toException @SomeException)) >>= k FindFiles dir exts excludeDirs k -> (findFilesInDir dir exts excludeDirs `catchIO` (throwError . toException @SomeException)) >>= k - Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> runFilesC k - Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> runFilesC k) + Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> k + Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> k eff (R other) = FilesC (eff (handleCoercible other)) readBlob :: (Member Files sig, Carrier sig m) => File -> m Blob -readBlob file = send (Read (FromPath file) ret) +readBlob file = send (Read (FromPath file) pure) -- | 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 sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob] -readBlobs (Left handle) = send (Read (FromHandle handle) ret) -readBlobs (Right paths) = traverse (send . flip Read ret . FromPath) paths +readBlobs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [File] -> m [Blob] +readBlobs (Left handle) = send (Read (FromHandle handle) pure) +readBlobs (Right paths) = traverse (send . flip Read pure . FromPath) paths -- | 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 sig, Carrier sig m, Applicative m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair] -readBlobPairs (Left handle) = send (Read (FromPairHandle handle) ret) -readBlobPairs (Right paths) = traverse (send . flip Read ret . FromPathPair) paths +readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair] +readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure) +readBlobPairs (Right paths) = traverse (send . flip Read pure . FromPathPair) paths readProject :: (Member Files sig, Carrier sig m) => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project -readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs ret) +readProject rootDir dir lang excludeDirs = send (ReadProject rootDir dir lang excludeDirs pure) findFiles :: (Member Files sig, Carrier sig m) => FilePath -> [String] -> [FilePath] -> m [FilePath] -findFiles dir exts paths = send (FindFiles dir exts paths ret) +findFiles dir exts paths = send (FindFiles dir exts paths pure) -- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'. write :: (Member Files sig, Carrier sig m) => Destination -> B.Builder -> m () -write dest builder = send (Write dest builder (ret ())) +write dest builder = send (Write dest builder (pure ())) -- | Generalize 'Exc.catch' to other 'MonadIO' contexts for the handler and result. diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index a3b52d484..5abf0bdee 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DerivingStrategies, GADTs, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DerivingStrategies, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-} module Semantic.Telemetry ( -- Async telemetry interface @@ -52,6 +52,7 @@ module Semantic.Telemetry import Control.Effect import Control.Effect.Carrier +import Control.Effect.Reader import Control.Effect.Sum import Control.Exception import Control.Monad.IO.Class @@ -121,11 +122,11 @@ queueStat q = liftIO . writeAsyncQueue q -- | A task which logs a message at a specific log level to stderr. writeLog :: (Member Telemetry sig, Carrier sig m) => Level -> String -> [(String, String)] -> m () -writeLog level message pairs = send (WriteLog level message pairs (ret ())) +writeLog level message pairs = send (WriteLog level message pairs (pure ())) -- | A task which writes a stat. writeStat :: (Member Telemetry sig, Carrier sig m) => Stat -> m () -writeStat stat = send (WriteStat stat (ret ())) +writeStat stat = send (WriteStat stat (pure ())) -- | A task which measures and stats the timing of another task. time :: (Member Telemetry sig, Carrier sig m, MonadIO m) => String -> [(String, String)] -> m output -> m output @@ -151,8 +152,8 @@ instance Effect Telemetry where handle state handler (WriteLog level message pairs k) = WriteLog level message pairs (handler (k <$ state)) -- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to. -runTelemetry :: (Carrier sig m, MonadIO m) => LogQueue -> StatQueue -> TelemetryC m a -> m a -runTelemetry logger statter = flip runTelemetryC (logger, statter) +runTelemetry :: LogQueue -> StatQueue -> TelemetryC m a -> m a +runTelemetry logger statter = runReader (logger, statter) . runTelemetryC newtype TelemetryC m a = TelemetryC { runTelemetryC :: ReaderC (LogQueue, StatQueue) m a } deriving (Applicative, Functor, Monad, MonadIO) @@ -166,13 +167,13 @@ instance (Carrier sig m, MonadIO m) => Carrier (Telemetry :+: sig) (TelemetryC m eff (R other) = TelemetryC (eff (R (handleCoercible other))) -- | Run a 'Telemetry' effect by ignoring statting/logging. -ignoreTelemetry :: Carrier sig m => Eff (IgnoreTelemetryC m) a -> m a -ignoreTelemetry = runIgnoreTelemetryC . interpret +ignoreTelemetry :: IgnoreTelemetryC m a -> m a +ignoreTelemetry = runIgnoreTelemetryC newtype IgnoreTelemetryC m a = IgnoreTelemetryC { runIgnoreTelemetryC :: m a } + deriving (Applicative, Functor, Monad) instance Carrier sig m => Carrier (Telemetry :+: sig) (IgnoreTelemetryC m) where - ret = IgnoreTelemetryC . ret - eff = handleSum (IgnoreTelemetryC . eff . handlePure runIgnoreTelemetryC) (\case - WriteStat _ k -> k - WriteLog _ _ _ k -> k) + eff (R other) = IgnoreTelemetryC . eff . handleCoercible $ other + eff (L (WriteStat _ k)) = k + eff (L (WriteLog _ _ _ k)) = k diff --git a/src/Semantic/Timeout.hs b/src/Semantic/Timeout.hs index 7e5f371e1..8dc5173e2 100644 --- a/src/Semantic/Timeout.hs +++ b/src/Semantic/Timeout.hs @@ -9,6 +9,7 @@ module Semantic.Timeout import Control.Effect import Control.Effect.Carrier +import Control.Effect.Reader import Control.Effect.Sum import Control.Monad.IO.Class import Data.Duration @@ -18,7 +19,7 @@ import qualified System.Timeout as System -- within the specified duration. Uses 'System.Timeout.timeout' so all caveats -- about not operating over FFI boundaries apply. timeout :: (Member Timeout sig, Carrier sig m) => Duration -> m output -> m (Maybe output) -timeout n = send . flip (Timeout n) ret +timeout n = send . flip (Timeout n) pure -- | 'Timeout' effects run other effects, aborting them if they exceed the -- specified duration. diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 439a512c9..e9860ba3f 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -58,40 +58,30 @@ justEvaluating :: Evaluator (Value term Precise) (ResumableC (BaseError (ValueError term Precise)) - (Eff (ResumableC (BaseError (AddressError Precise (Value term Precise))) - (Eff (ResumableC (BaseError ResolutionError) - (Eff (ResumableC (BaseError (EvalError term Precise (Value term Precise))) - (Eff (ResumableC (BaseError (HeapError Precise)) - (Eff (ResumableC (BaseError (ScopeError Precise)) - (Eff (ResumableC (BaseError (UnspecializedError Precise (Value term Precise))) - (Eff (ResumableC (BaseError (LoadError Precise (Value term Precise))) - (Eff (FreshC - (Eff (StateC (ScopeGraph Precise) - (Eff (StateC (Heap Precise @@ -99,11 +89,9 @@ justEvaluating :: Evaluator (Value term Precise)) - (Eff (TraceByPrintingC - (Eff (LiftC - IO))))))))))))))))))))))))) + IO))))))))))))) result -> IO (Heap Precise Precise (Value term Precise), @@ -148,18 +136,18 @@ justEvaluatingCatchingErrors :: ( hole ~ Hole (Maybe Name) Precise value (ResumableWithC (BaseError (ValueError term hole)) - (Eff (ResumableWithC (BaseError (AddressError hole value)) - (Eff (ResumableWithC (BaseError ResolutionError) - (Eff (ResumableWithC (BaseError (EvalError term hole value)) - (Eff (ResumableWithC (BaseError (HeapError hole)) - (Eff (ResumableWithC (BaseError (ScopeError hole)) - (Eff (ResumableWithC (BaseError (UnspecializedError hole value)) - (Eff (ResumableWithC (BaseError (LoadError hole value)) - (Eff (FreshC - (Eff (StateC (ScopeGraph hole) - (Eff (StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise))) - (Eff (TraceByPrintingC - (Eff (LiftC IO))))))))))))))))))))))))) a + (ResumableWithC (BaseError (AddressError hole value)) + (ResumableWithC (BaseError ResolutionError) + (ResumableWithC (BaseError (EvalError term hole value)) + (ResumableWithC (BaseError (HeapError hole)) + (ResumableWithC (BaseError (ScopeError hole)) + (ResumableWithC (BaseError (UnspecializedError hole value)) + (ResumableWithC (BaseError (LoadError hole value)) + (FreshC + (StateC (ScopeGraph hole) + (StateC (Heap hole hole (Concrete.Value (Quieterm (Sum lang) Location) (Hole (Maybe Name) Precise))) + (TraceByPrintingC + (LiftC IO))))))))))))) a -> IO (Heap hole hole value, (ScopeGraph hole, a)) justEvaluatingCatchingErrors = runM @@ -185,84 +173,67 @@ checking (ResumableC (BaseError Type.TypeError) - (Eff (StateC Type.TypeMap - (Eff (ResumableC (BaseError (AddressError Monovariant Type.Type)) - (Eff (ResumableC (BaseError (EvalError term Monovariant Type.Type)) - (Eff (ResumableC (BaseError ResolutionError) - (Eff (ResumableC (BaseError (HeapError Monovariant)) - (Eff (ResumableC (BaseError (ScopeError Monovariant)) - (Eff (ResumableC (BaseError (UnspecializedError Monovariant Type.Type)) - (Eff (ResumableC (BaseError (LoadError Monovariant Type.Type)) - (Eff (ReaderC (Live Monovariant) - (Eff (AltC [] - (Eff (ReaderC (Cache term Monovariant Type.Type) - (Eff (StateC (Cache term Monovariant Type.Type) - (Eff (FreshC - (Eff (StateC (ScopeGraph Monovariant) - (Eff (StateC (Heap Monovariant Monovariant Type.Type) - (Eff (TraceByPrintingC - (Eff (LiftC - IO))))))))))))))))))))))))))))))))))) + IO)))))))))))))))))) result -> IO (Heap @@ -564,17 +535,18 @@ callGraphRubyProject :: [FilePath] -> IO (Graph ControlFlowVertex, [Module ()]) callGraphRubyProject = callGraphProject rubyParser (Proxy @'Language.Ruby) type EvalEffects qterm err = ResumableC (BaseError err) - (Eff (ResumableC (BaseError (AddressError Precise (Value qterm Precise))) - (Eff (ResumableC (BaseError ResolutionError) - (Eff (ResumableC (BaseError (EvalError qterm Precise (Value qterm Precise))) - (Eff (ResumableC (BaseError (HeapError Precise)) - (Eff (ResumableC (BaseError (ScopeError Precise)) - (Eff (ResumableC (BaseError (UnspecializedError Precise (Value qterm Precise))) - (Eff (ResumableC (BaseError (LoadError Precise (Value qterm Precise))) - (Eff (FreshC (Eff (StateC (ScopeGraph Precise) - (Eff (StateC (Heap Precise Precise (Value qterm Precise)) - (Eff (TraceByPrintingC - (Eff (LiftC IO)))))))))))))))))))))))) + (ResumableC (BaseError (AddressError Precise (Value qterm Precise))) + (ResumableC (BaseError ResolutionError) + (ResumableC (BaseError (EvalError qterm Precise (Value qterm Precise))) + (ResumableC (BaseError (HeapError Precise)) + (ResumableC (BaseError (ScopeError Precise)) + (ResumableC (BaseError (UnspecializedError Precise (Value qterm Precise))) + (ResumableC (BaseError (LoadError Precise (Value qterm Precise))) + (FreshC + (StateC (ScopeGraph Precise) + (StateC (Heap Precise Precise (Value qterm Precise)) + (TraceByPrintingC + (LiftC IO)))))))))))) type LanguageSyntax lang syntax = ( Language.SLanguage lang , HasPrelude lang @@ -643,18 +615,18 @@ evaluateProjectForScopeGraph :: ( term ~ Term (Sum syntax) Location -> IO (Evaluator qterm address (Value qterm address) (ResumableWithC (BaseError (ValueError qterm address)) - (Eff (ResumableWithC (BaseError (AddressError address (Value qterm address))) - (Eff (ResumableWithC (BaseError ResolutionError) - (Eff (ResumableWithC (BaseError (EvalError qterm address (Value qterm address))) - (Eff (ResumableWithC (BaseError (HeapError address)) - (Eff (ResumableWithC (BaseError (ScopeError address)) - (Eff (ResumableWithC (BaseError (UnspecializedError address (Value qterm address))) - (Eff (ResumableWithC (BaseError (LoadError address (Value qterm address))) - (Eff (FreshC - (Eff (StateC (ScopeGraph address) - (Eff (StateC (Heap address address (Value qterm address)) - (Eff (TraceByPrintingC - (Eff (LiftC IO))))))))))))))))))))))))) + (ResumableWithC (BaseError (AddressError address (Value qterm address))) + (ResumableWithC (BaseError ResolutionError) + (ResumableWithC (BaseError (EvalError qterm address (Value qterm address))) + (ResumableWithC (BaseError (HeapError address)) + (ResumableWithC (BaseError (ScopeError address)) + (ResumableWithC (BaseError (UnspecializedError address (Value qterm address))) + (ResumableWithC (BaseError (LoadError address (Value qterm address))) + (FreshC + (StateC (ScopeGraph address) + (StateC (Heap address address (Value qterm address)) + (TraceByPrintingC + (LiftC IO))))))))))))) (ModuleTable (Module (ModuleResult address (Value qterm address))))) evaluateProjectForScopeGraph proxy parser project = runTask' $ do @@ -678,22 +650,23 @@ evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location -> FilePath -> IO (Evaluator qterm Monovariant Type (ResumableC (BaseError Type.TypeError) - (Eff (StateC TypeMap - (Eff (ResumableC (BaseError (AddressError Monovariant Type)) - (Eff (ResumableC (BaseError (EvalError qterm Monovariant Type)) - (Eff (ResumableC (BaseError ResolutionError) - (Eff (ResumableC (BaseError (HeapError Monovariant)) - (Eff (ResumableC (BaseError (ScopeError Monovariant)) - (Eff (ResumableC (BaseError (UnspecializedError Monovariant Type)) - (Eff (ResumableC (BaseError (LoadError Monovariant Type)) - (Eff (ReaderC (Live Monovariant) - (Eff (AltC [] - (Eff (ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type) - (Eff (StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type) - (Eff (FreshC - (Eff (StateC (ScopeGraph Monovariant) - (Eff (StateC (Heap Monovariant Monovariant Type) - (Eff (TraceByPrintingC (Eff (LiftC IO))))))))))))))))))))))))))))))))))) + (StateC TypeMap + (ResumableC (BaseError (AddressError Monovariant Type)) + (ResumableC (BaseError (EvalError qterm Monovariant Type)) + (ResumableC (BaseError ResolutionError) + (ResumableC (BaseError (HeapError Monovariant)) + (ResumableC (BaseError (ScopeError Monovariant)) + (ResumableC (BaseError (UnspecializedError Monovariant Type)) + (ResumableC (BaseError (LoadError Monovariant Type)) + (ReaderC (Live Monovariant) + (AltC [] + (ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type) + (StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type) + (FreshC + (StateC (ScopeGraph Monovariant) + (StateC (Heap Monovariant Monovariant Type) + (TraceByPrintingC + (LiftC IO)))))))))))))))))) (ModuleTable (Module (ModuleResult Monovariant Type)))) evaluateProjectWithCaching proxy parser path = runTask' $ do project <- readProject Nothing path (Language.reflect proxy) [] diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 2538ce42e..a3094b302 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -69,7 +69,7 @@ evaluate . runValueError . runAddressError . runEvalError - . runDeref @Val + . runDeref @SpecEff . runAllocator . runReturn . runLoopControl @@ -85,29 +85,29 @@ reassociate = mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeError type Val = Value SpecEff Precise newtype SpecEff = SpecEff { runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val - (Eff (BooleanC Val - (Eff (NumericC Val - (Eff (ErrorC (LoopControl Val) - (Eff (ErrorC (Return Val) - (Eff (AllocatorC Precise - (Eff (DerefC Precise Val - (Eff (ResumableC (BaseError (EvalError SpecEff Precise Val)) - (Eff (ResumableC (BaseError (AddressError Precise Val)) - (Eff (ResumableC (BaseError (ValueError SpecEff Precise)) - (Eff (ResumableC (BaseError (HeapError Precise)) - (Eff (ResumableC (BaseError (ScopeError Precise)) - (Eff (ReaderC (CurrentFrame Precise) - (Eff (ReaderC (CurrentScope Precise) - (Eff (AllocatorC Precise - (Eff (ReaderC Span - (Eff (StateC Span - (Eff (ReaderC ModuleInfo - (Eff (ReaderC PackageInfo - (Eff (FreshC - (Eff (StateC (Heap Precise Precise Val) - (Eff (StateC (ScopeGraph Precise) - (Eff (TraceByIgnoringC - (Eff (LiftC IO))))))))))))))))))))))))))))))))))))))))))))))) + (BooleanC Val + (NumericC Val + (ErrorC (LoopControl Val) + (ErrorC (Return Val) + (AllocatorC Precise + (DerefC Precise Val + (ResumableC (BaseError (EvalError SpecEff Precise Val)) + (ResumableC (BaseError (AddressError Precise Val)) + (ResumableC (BaseError (ValueError SpecEff Precise)) + (ResumableC (BaseError (HeapError Precise)) + (ResumableC (BaseError (ScopeError Precise)) + (ReaderC (CurrentFrame Precise) + (ReaderC (CurrentScope Precise) + (AllocatorC Precise + (ReaderC Span + (StateC Span + (ReaderC ModuleInfo + (ReaderC PackageInfo + (FreshC + (StateC (Heap Precise Precise Val) + (StateC (ScopeGraph Precise) + (TraceByIgnoringC + (LiftC IO)))))))))))))))))))))))) Val } diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 460dd2ca3..9b9510e6a 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -117,19 +117,19 @@ runTaskOrDie :: TaskEff a -> IO a runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } task >>= either (die . displayException) pure type TestEvaluatingC term - = ResumableC (BaseError (AddressError Precise (Val term))) (Eff - ( ResumableC (BaseError (ValueError term Precise)) (Eff - ( ResumableC (BaseError ResolutionError) (Eff - ( ResumableC (BaseError (EvalError term Precise (Val term))) (Eff - ( ResumableC (BaseError (HeapError Precise)) (Eff - ( ResumableC (BaseError (ScopeError Precise)) (Eff - ( ResumableC (BaseError (UnspecializedError Precise (Val term))) (Eff - ( ResumableC (BaseError (LoadError Precise (Val term))) (Eff - ( StateC (Heap Precise Precise (Val term)) (Eff - ( StateC (ScopeGraph Precise) (Eff - ( FreshC (Eff - ( TraceByIgnoringC (Eff - ( LiftC IO)))))))))))))))))))))))) + = ResumableC (BaseError (AddressError Precise (Val term))) + ( ResumableC (BaseError (ValueError term Precise)) + ( ResumableC (BaseError ResolutionError) + ( ResumableC (BaseError (EvalError term Precise (Val term))) + ( ResumableC (BaseError (HeapError Precise)) + ( ResumableC (BaseError (ScopeError Precise)) + ( ResumableC (BaseError (UnspecializedError Precise (Val term))) + ( ResumableC (BaseError (LoadError Precise (Val term))) + ( StateC (Heap Precise Precise (Val term)) + ( StateC (ScopeGraph Precise) + ( FreshC + ( TraceByIgnoringC + ( LiftC IO)))))))))))) type TestEvaluatingErrors term = '[ BaseError (AddressError Precise (Val term)) , BaseError (ValueError term Precise) From 2fa32624ac3be8a2807b104f5ca7e8ebf3f90786 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 6 Mar 2019 10:43:12 -0500 Subject: [PATCH 22/32] lints --- src/Control/Abstract/Modules.hs | 2 +- src/Control/Abstract/Value.hs | 18 +++++++++--------- src/Control/Effect/Catch.hs | 2 +- src/Control/Effect/REPL.hs | 2 +- src/Data/Abstract/Address/Hole.hs | 2 +- src/Data/Abstract/Address/Monovariant.hs | 2 +- src/Data/Abstract/Address/Precise.hs | 2 +- src/Data/Abstract/Value/Abstract.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 2 +- src/Diffing/Interpreter.hs | 2 +- src/Rendering/Graph.hs | 3 +-- src/Reprinting/Translate.hs | 3 +-- src/Semantic/REPL.hs | 2 +- src/Semantic/Resolution.hs | 2 +- src/Semantic/Task.hs | 2 +- src/Semantic/Task/Files.hs | 2 +- src/Semantic/Telemetry.hs | 2 +- src/Tags/Tagging.hs | 3 +-- 18 files changed, 26 insertions(+), 29 deletions(-) diff --git a/src/Control/Abstract/Modules.hs b/src/Control/Abstract/Modules.hs index 133120e78..7d71758cd 100644 --- a/src/Control/Abstract/Modules.hs +++ b/src/Control/Abstract/Modules.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, LambdaCase, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Control.Abstract.Modules ( ModuleResult , lookupModule diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 9ec597bcf..fd4250aa0 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -174,7 +174,7 @@ instance Effect (Boolean value) where runBoolean :: Evaluator term address value (BooleanC value m) a -> Evaluator term address value m a -runBoolean = raiseHandler $ runBooleanC +runBoolean = raiseHandler runBooleanC newtype BooleanC value m a = BooleanC { runBooleanC :: m a } deriving stock Functor @@ -225,7 +225,7 @@ instance HFunctor (While value) where runWhile :: Evaluator term address value (WhileC value m) a -> Evaluator term address value m a -runWhile = raiseHandler $ runWhileC +runWhile = raiseHandler runWhileC newtype WhileC value m a = WhileC { runWhileC :: m a } deriving stock Functor @@ -248,7 +248,7 @@ instance Effect (Unit value) where runUnit :: Evaluator term address value (UnitC value m) a -> Evaluator term address value m a -runUnit = raiseHandler $ runUnitC +runUnit = raiseHandler runUnitC newtype UnitC value m a = UnitC { runUnitC :: m a } deriving stock Functor @@ -281,7 +281,7 @@ newtype StringC value m a = StringC { runStringC :: m a } runString :: Evaluator term address value (StringC value m) a -> Evaluator term address value m a -runString = raiseHandler $ runStringC +runString = raiseHandler runStringC -- | Construct an abstract integral value. @@ -335,7 +335,7 @@ newtype NumericC value m a = NumericC { runNumericC :: m a } runNumeric :: Evaluator term address value (NumericC value m) a -> Evaluator term address value m a -runNumeric = raiseHandler $ runNumericC +runNumeric = raiseHandler runNumericC -- | Cast numbers to integers @@ -381,7 +381,7 @@ instance Effect (Bitwise value) where runBitwise :: Evaluator term address value (BitwiseC value m) a -> Evaluator term address value m a -runBitwise = raiseHandler $ runBitwiseC +runBitwise = raiseHandler runBitwiseC newtype BitwiseC value m a = BitwiseC { runBitwiseC :: m a } deriving stock Functor @@ -419,7 +419,7 @@ newtype ObjectC address value m a = ObjectC { runObjectC :: m a } runObject :: Evaluator term address value (ObjectC address value m) a -> Evaluator term address value m a -runObject = raiseHandler $ runObjectC +runObject = raiseHandler runObjectC -- | Construct an array of zero or more values. array :: (Member (Array value) sig, Carrier sig m) => [value] -> m value @@ -446,7 +446,7 @@ newtype ArrayC value m a = ArrayC { runArrayC :: m a } runArray :: Evaluator term address value (ArrayC value m) a -> Evaluator term address value m a -runArray = raiseHandler $ runArrayC +runArray = raiseHandler runArrayC -- | Construct a hash out of pairs. hash :: (Member (Hash value) sig, Carrier sig m) => [(value, value)] -> m value @@ -474,7 +474,7 @@ newtype HashC value m a = HashC { runHashC :: m a } runHash :: Evaluator term address value (HashC value m) a -> Evaluator term address value m a -runHash = raiseHandler $ runHashC +runHash = raiseHandler runHashC class Show value => AbstractIntro value where -- | Construct the nil/null datatype. diff --git a/src/Control/Effect/Catch.hs b/src/Control/Effect/Catch.hs index 2dfbe78c6..3d98a269d 100644 --- a/src/Control/Effect/Catch.hs +++ b/src/Control/Effect/Catch.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, - LambdaCase, MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} + MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} -- | An effect that enables catching exceptions thrown from -- impure computations such as IO. diff --git a/src/Control/Effect/REPL.hs b/src/Control/Effect/REPL.hs index 7be7c350a..b0f80f992 100644 --- a/src/Control/Effect/REPL.hs +++ b/src/Control/Effect/REPL.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} module Control.Effect.REPL ( REPL (..) diff --git a/src/Data/Abstract/Address/Hole.hs b/src/Data/Abstract/Address/Hole.hs index 8144ccb11..7d82a1c7b 100644 --- a/src/Data/Abstract/Address/Hole.hs +++ b/src/Data/Abstract/Address/Hole.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE TypeOperators, UndecidableInstances #-} module Data.Abstract.Address.Hole ( Hole(..) , toMaybe diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs index e26a4b912..5e2fc2337 100644 --- a/src/Data/Abstract/Address/Monovariant.hs +++ b/src/Data/Abstract/Address/Monovariant.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE TypeOperators, UndecidableInstances #-} module Data.Abstract.Address.Monovariant ( Monovariant(..) ) where diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index 82f58f913..6e8892b0d 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-} module Data.Abstract.Address.Precise ( Precise(..) ) where diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 4bb8847a1..87a463484 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE TypeOperators, UndecidableInstances #-} module Data.Abstract.Value.Abstract ( Abstract (..) , runFunction diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 6202323d4..d92700fb9 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, GADTs, RankNTypes, TypeOperators, UndecidableInstances, LambdaCase, ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass, GADTs, RankNTypes, TypeOperators, UndecidableInstances, ScopedTypeVariables #-} module Data.Abstract.Value.Concrete ( Value (..) , ValueError (..) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 70cc5fafd..bd46e142d 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-} module Diffing.Interpreter ( diffTerms , diffTermPair diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 3180f401f..0af74b5cf 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -28,8 +28,7 @@ renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t - renderTreeGraph = simplify . runGraph . cata toTreeGraph runGraph :: ReaderC (Graph vertex) - (FreshC - (VoidC)) (Graph vertex) + (FreshC VoidC) (Graph vertex) -> Graph vertex runGraph = run . runFresh . runReader mempty diff --git a/src/Reprinting/Translate.hs b/src/Reprinting/Translate.hs index ec06426da..c5081c126 100644 --- a/src/Reprinting/Translate.hs +++ b/src/Reprinting/Translate.hs @@ -20,8 +20,7 @@ import qualified Data.Source as Source type Translator = StateC [Scope] - ( ErrorC TranslationError - ( VoidC )) + ( ErrorC TranslationError VoidC) contextualizing :: ProcessT Translator Token Fragment contextualizing = repeatedly $ await >>= \case diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index dadcb9c86..9c753f930 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, LambdaCase, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.REPL ( rubyREPL diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 6fd11904a..d5c05b221 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.Resolution ( Resolution (..) , nodeJSResolutionMap diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 0899b96bd..a08571fdd 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} module Semantic.Task ( Task , TaskEff diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index eb392b413..5aa73b5e8 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, LambdaCase, KindSignatures, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification, GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} module Semantic.Task.Files ( Files diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 5abf0bdee..36882fd11 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DerivingStrategies, GADTs, GeneralizedNewtypeDeriving, KindSignatures, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DerivingStrategies, GADTs, GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, TypeOperators, UndecidableInstances #-} module Semantic.Telemetry ( -- Async telemetry interface diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index 27b9e237f..0549a33a3 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -39,8 +39,7 @@ type ContextToken = (Text, Maybe Range) type Contextualizer = StateC [ContextToken] - ( ErrorC TranslationError - ( VoidC)) + ( ErrorC TranslationError VoidC) contextualizing :: Blob -> Machine.ProcessT Contextualizer Token Tag contextualizing Blob{..} = repeatedly $ await >>= \case From 256d22c6d280017b716a9893f32884585a62c790 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 6 Mar 2019 10:52:58 -0500 Subject: [PATCH 23/32] fix (?) PythonPackaging --- src/Control/Abstract/PythonPackage.hs | 49 +++++++++++++-------------- 1 file changed, 24 insertions(+), 25 deletions(-) diff --git a/src/Control/Abstract/PythonPackage.hs b/src/Control/Abstract/PythonPackage.hs index c7119e71a..dd9514907 100644 --- a/src/Control/Abstract/PythonPackage.hs +++ b/src/Control/Abstract/PythonPackage.hs @@ -32,29 +32,28 @@ instance ( Carrier sig m , Member (Abstract.Array (Value term address)) sig ) => Carrier sig (PythonPackagingC term address m) where - -- eff (R other) = PythonPackagingC . eff . handleCoercible $ other - -- eff (L op) - -- | Just e <- prj op = wrap $ case handleCoercible e of - -- Call callName params k -> Evaluator . k =<< do - -- case callName of - -- Closure _ _ name' _ paramNames _ _ _ -> do - -- let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params) - -- let asStrings = asArray >=> traverse asString + eff op + | Just e <- prj op = wrap $ case handleCoercible e of + Call callName params k -> Evaluator . k =<< do + case callName of + Closure _ _ name' _ paramNames _ _ _ -> do + let bindings = foldr (uncurry Map.insert) lowerBound (zip paramNames params) + let asStrings = asArray >=> traverse asString - -- if Just (name "find_packages") == name' then do - -- as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings) - -- put (FindPackages as) - -- else if Just (name "setup") == name' then do - -- packageState <- get - -- if packageState == Control.Abstract.PythonPackage.Unknown then do - -- as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings) - -- put (Packages as) - -- else - -- pure () - -- else pure () - -- _ -> pure () - -- call callName params - -- Function name params body scope k -> function name params body scope >>= Evaluator . k - -- BuiltIn n b k -> builtIn n b >>= Evaluator . k - -- Bind obj value k -> bindThis obj value >>= Evaluator . k - -- | otherwise = PythonPackagingC (eff (handleCoercible op)) + if Just (name "find_packages") == name' then do + as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "exclude") bindings) + put (FindPackages as) + else if Just (name "setup") == name' then do + packageState <- get + if packageState == Control.Abstract.PythonPackage.Unknown then do + as <- maybe (pure mempty) (fmap (fmap stripQuotes) . asStrings) (Map.lookup (name "packages") bindings) + put (Packages as) + else + pure () + else pure () + _ -> pure () + call callName params + Function name params body scope k -> function name params body scope >>= Evaluator . k + BuiltIn n b k -> builtIn n b >>= Evaluator . k + Bind obj value k -> bindThis obj value >>= Evaluator . k + | otherwise = PythonPackagingC . eff $ handleCoercible op From 9845db1ac924d79fa4a7fabadceabbfcad845331 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 6 Mar 2019 14:13:35 -0500 Subject: [PATCH 24/32] stuck on eavesdrop --- src/Analysis/Abstract/Graph.hs | 9 ++----- src/Data/Abstract/Value/Concrete.hs | 42 +++++++++++++++++++++++++---- 2 files changed, 39 insertions(+), 12 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 788b9998c..63c4102a7 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -160,13 +160,8 @@ newtype EavesdropC address value m a = EavesdropC runHandler :: Handler address value m -> EavesdropC address value m a -> m a runHandler h = runReader h . runEavesdropC -instance (Carrier sig m, Member (Modules address value) sig, Applicative m) => Carrier sig (EavesdropC address value m) where - -- eff (R other) = _ other - -- eff (L op) = do - -- handler <- EavesdropC ask - -- case prj op of - -- Just e -> runHandler handler e *> send e - -- Nothing -> undefined +instance forall sig m address value . (Carrier sig m, Member (Modules address value) sig, Applicative m) => Carrier sig (EavesdropC address value m) where + -- | Add an edge from the current package to the passed vertex. packageInclusion :: ( Member (Reader PackageInfo) sig diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index d92700fb9..a7d43752b 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, GADTs, RankNTypes, TypeOperators, UndecidableInstances, ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass, GADTs, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances, ScopedTypeVariables #-} module Data.Abstract.Value.Concrete ( Value (..) , ValueError (..) @@ -141,7 +141,28 @@ instance ( Carrier sig m , Member (Interpose (Resumable (BaseError (UnspecializedError address (Value term address))))) sig ) => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where - -- eff = WhileC . handleSum (eff . handleCoercible) (\case + eff (R other) = WhileC . eff . handleCoercible $ other + eff (L (Abstract.While cond body k)) = do + let loop x = catchLoopControl (fix x) $ \case + Break value -> pure value + Abort -> pure Unit + -- FIXME: Figure out how to deal with this. Ruby treats this as the result + -- of the current block iteration, while PHP specifies a breakout level + -- and TypeScript appears to take a label. + Continue _ -> loop x + + let eval = runEvaluator . loop $ \continue -> do + cond' <- Evaluator cond + ifthenelse cond' (Evaluator body *> continue) (pure Unit) + + interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) eval + (\case + -- We can't move this case outside the 'interpose' because + -- otherwise we hit errors about untouchable type variables + Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) + Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address)) + ) >>= k + -- Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do cond' <- Evaluator (runWhileC cond) -- -- `interpose` is used to handle 'UnspecializedError's and abort out of the @@ -149,9 +170,7 @@ instance ( Carrier sig m -- -- conditional always being true and getting stuck in an infinite loop. -- ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit)))) - -- (\case - -- Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) - -- Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) + -- ( -- >>= runWhileC . k) -- where -- loop x = catchLoopControl (fix x) $ \case @@ -162,6 +181,19 @@ instance ( Carrier sig m -- -- and TypeScript appears to take a label. -- Continue _ -> loop x + -- case op of + -- Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do + -- cond' <- Evaluator (runWhileC cond) + + -- -- `interpose` is used to handle 'UnspecializedError's and abort out of the + -- -- loop, otherwise under concrete semantics we run the risk of the + -- -- conditional always being true and getting stuck in an infinite loop. + + -- ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit) + -- case _ of + -- Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) >>= k + -- Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) >>= k + instance Carrier sig m => Carrier (Abstract.Unit (Value term address) :+: sig) (UnitC (Value term address) m) where From 2bb5e8d9e16baf47a218a6a1be6e8e846a76a9e2 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 6 Mar 2019 14:38:52 -0500 Subject: [PATCH 25/32] restore the old definition of EavesdropC --- src/Analysis/Abstract/Graph.hs | 21 ++++++++--------- src/Data/Abstract/Value/Concrete.hs | 36 ++++++++++++++--------------- 2 files changed, 27 insertions(+), 30 deletions(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 63c4102a7..310f75666 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DerivingVia, GeneralizedNewtypeDeriving, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Graph ( Graph(..) , ControlFlowVertex(..) @@ -149,19 +149,18 @@ graphingModuleInfo recur m = do eavesdrop :: Evaluator term address value (EavesdropC address value m) a -> (forall x . Modules address value m (m x) -> Evaluator term address value m ()) -> Evaluator term address value m a -eavesdrop m f = raiseHandler (runHandler (Handler (runEvaluator . f))) m +eavesdrop m f = raiseHandler (runEavesdropC (runEvaluator . f)) m -newtype Handler address value m = Handler (forall x . Modules address value m (m x) -> m ()) +newtype EavesdropC address value m a = EavesdropC ((forall x . Modules address value m (m x) -> m ()) -> m a) + deriving (Alternative, Applicative, Functor, Monad) via (ReaderC (forall x . Modules address value m (m x) -> m ()) m) -newtype EavesdropC address value m a = EavesdropC - { runEavesdropC :: ReaderC (Handler address value m) m a - } deriving (Alternative, Applicative, Functor, Monad) - -runHandler :: Handler address value m -> EavesdropC address value m a -> m a -runHandler h = runReader h . runEavesdropC - -instance forall sig m address value . (Carrier sig m, Member (Modules address value) sig, Applicative m) => Carrier sig (EavesdropC address value m) where +runEavesdropC :: (forall x . Modules address value m (m x) -> m ()) -> EavesdropC address value m a -> m a +runEavesdropC f (EavesdropC m) = m f +instance (Carrier sig m, Member (Modules address value) sig, Applicative m) => Carrier sig (EavesdropC address value m) where + eff op + | Just eff <- prj op = EavesdropC (\ handler -> let eff' = handlePure (runEavesdropC handler) eff in handler eff' *> send eff') + | otherwise = EavesdropC (\ handler -> eff (handlePure (runEavesdropC handler) op)) -- | Add an edge from the current package to the passed vertex. packageInclusion :: ( Member (Reader PackageInfo) sig diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index a7d43752b..9cc01a6a0 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -133,8 +133,6 @@ instance ( Member (Reader ModuleInfo) sig Abstract.AsBool (Boolean b) k -> k b Abstract.AsBool other k -> throwBaseError (BoolError other) >>= k --- PT FIXME: this one is gnarly - instance ( Carrier sig m , Member (Abstract.Boolean (Value term address)) sig , Member (Error (LoopControl (Value term address))) sig @@ -142,26 +140,26 @@ instance ( Carrier sig m ) => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where eff (R other) = WhileC . eff . handleCoercible $ other - eff (L (Abstract.While cond body k)) = do - let loop x = catchLoopControl (fix x) $ \case - Break value -> pure value - Abort -> pure Unit - -- FIXME: Figure out how to deal with this. Ruby treats this as the result - -- of the current block iteration, while PHP specifies a breakout level - -- and TypeScript appears to take a label. - Continue _ -> loop x + eff (L (Abstract.While cond body k)) = WhileC $ (interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do + cond' <- Evaluator (runWhileC cond) - let eval = runEvaluator . loop $ \continue -> do - cond' <- Evaluator cond - ifthenelse cond' (Evaluator body *> continue) (pure Unit) + -- `interpose` is used to handle 'UnspecializedError's and abort out of the + -- loop, otherwise under concrete semantics we run the risk of the + -- conditional always being true and getting stuck in an infinite loop. - interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) eval + ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit)))) (\case - -- We can't move this case outside the 'interpose' because - -- otherwise we hit errors about untouchable type variables - Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) - Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address)) - ) >>= k + Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) + Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address)))) + >>= runWhileC . k + where + loop x = catchLoopControl (fix x) $ \case + Break value -> pure value + Abort -> pure Unit + -- FIXME: Figure out how to deal with this. Ruby treats this as the result + -- of the current block iteration, while PHP specifies a breakout level + -- and TypeScript appears to take a label. + Continue _ -> loop x -- Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do cond' <- Evaluator (runWhileC cond) From 9120c9858d498c10f7a037a5daea908b03a2ce89 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 6 Mar 2019 17:10:32 -0500 Subject: [PATCH 26/32] more fixes --- src/Analysis/Abstract/Collecting.hs | 2 +- src/Data/Abstract/Value/Concrete.hs | 33 +++++++++++++++++------------ src/Semantic/AST.hs | 2 +- src/Semantic/REPL.hs | 2 +- 4 files changed, 22 insertions(+), 17 deletions(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index b811c78df..4a7d11f3c 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -5,5 +5,5 @@ module Analysis.Abstract.Collecting import Control.Abstract import Prologue -providingLiveSet :: Carrier sig m => Evaluator term address value (ReaderC (Live address) m) a -> Evaluator term address value m a +providingLiveSet :: Evaluator term address value (ReaderC (Live address) m) a -> Evaluator term address value m a providingLiveSet = raiseHandler (runReader lowerBound) diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 9cc01a6a0..7914e6cc8 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -26,6 +26,7 @@ import Data.Text (pack) import Data.Word import Prologue import qualified Data.Map.Strict as Map +import Debug.Trace (traceM) data Value term address -- TODO: Split Closure up into a separate data type. Scope Frame @@ -140,26 +141,30 @@ instance ( Carrier sig m ) => Carrier (Abstract.While (Value term address) :+: sig) (WhileC (Value term address) m) where eff (R other) = WhileC . eff . handleCoercible $ other - eff (L (Abstract.While cond body k)) = WhileC $ (interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do - cond' <- Evaluator (runWhileC cond) + eff (L (Abstract.While cond body k)) = do + + let loop x = catchLoopControl (fix x) $ \case + Break value -> let foo = pure value in traceM "Break" *> foo + Abort -> traceM "abort" *> pure Unit + -- FIXME: Figure out how to deal with this. Ruby treats this as the result + -- of the current block iteration, while PHP specifies a breakout level + -- and TypeScript appears to take a label. + Continue _ -> traceM "Continue" *> loop x + + res <- interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do + cond' <- Evaluator cond -- `interpose` is used to handle 'UnspecializedError's and abort out of the -- loop, otherwise under concrete semantics we run the risk of the -- conditional always being true and getting stuck in an infinite loop. - - ifthenelse cond' (Evaluator (runWhileC body) *> continue) (pure Unit)))) + traceM "ifthenelse" + ifthenelse cond' (Evaluator body *> continue) (pure Unit)))) (\case Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) - Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address)))) - >>= runWhileC . k - where - loop x = catchLoopControl (fix x) $ \case - Break value -> pure value - Abort -> pure Unit - -- FIXME: Figure out how to deal with this. Ruby treats this as the result - -- of the current block iteration, while PHP specifies a breakout level - -- and TypeScript appears to take a label. - Continue _ -> loop x + Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) + k res + + -- Abstract.While cond body k -> interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do cond' <- Evaluator (runWhileC cond) diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index 56b078494..e5d2e81bd 100644 --- a/src/Semantic/AST.hs +++ b/src/Semantic/AST.hs @@ -27,7 +27,7 @@ data SomeAST where withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a withSomeAST f (SomeAST ast) = f ast -astParseBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m, Functor m) => Blob -> m SomeAST +astParseBlob :: (Member (Error SomeException) sig, Member Task sig, Carrier sig m) => Blob -> m SomeAST astParseBlob blob@Blob{..} | Just (SomeASTParser parser) <- someASTParser blobLanguage = SomeAST <$> parse parser blob | otherwise = noLanguageForBlob blobPath diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 9c753f930..b33e7e730 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -100,7 +100,7 @@ repl proxy parser paths = -- TODO: drive the flow from within the REPL instead of from without -runTelemetryIgnoringStat :: (Carrier sig m, MonadIO m) => LogOptions -> TelemetryIgnoringStatC m a -> m a +runTelemetryIgnoringStat :: LogOptions -> TelemetryIgnoringStatC m a -> m a runTelemetryIgnoringStat logOptions = runReader logOptions . runTelemetryIgnoringStatC newtype TelemetryIgnoringStatC m a = TelemetryIgnoringStatC { runTelemetryIgnoringStatC :: ReaderC LogOptions m a } From f28f23c97daac0a3e5603e1236498942aafe9b08 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 6 Mar 2019 17:39:24 -0500 Subject: [PATCH 27/32] infinite blessings upon @rob_rix --- src/Analysis/Abstract/Caching/FlowInsensitive.hs | 8 ++++---- src/Analysis/Abstract/Caching/FlowSensitive.hs | 7 ++++--- src/Data/Abstract/Value/Concrete.hs | 4 ++-- src/Semantic/Util.hs | 5 ++--- vendor/fused-effects | 2 +- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Analysis/Abstract/Caching/FlowInsensitive.hs b/src/Analysis/Abstract/Caching/FlowInsensitive.hs index 1c59adf41..c5670e6bc 100644 --- a/src/Analysis/Abstract/Caching/FlowInsensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowInsensitive.hs @@ -84,7 +84,7 @@ convergingModules :: ( Eq value , Carrier sig m , Alternative m ) - => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe m) value) + => (Module (Either prelude term) -> Evaluator term address value (NonDetC m) value) -> (Module (Either prelude term) -> Evaluator term address value m value) convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty convergingModules recur m@(Module _ (Right term)) = do @@ -99,7 +99,7 @@ convergingModules recur m@(Module _ (Right term)) = do -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - withOracle prevCache (raiseHandler runNonDet (recur m))) + withOracle prevCache (raiseHandler (runNonDet @Maybe) (recur m))) maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. @@ -129,7 +129,7 @@ getConfiguration term = Configuration term <$> askRoots caching :: Carrier sig m - => Evaluator term address value (AltC B + => Evaluator term address value (NonDetC (ReaderC (Cache term address value) (StateC (Cache term address value) m))) a @@ -137,7 +137,7 @@ caching :: Carrier sig m caching = raiseHandler (runState lowerBound) . raiseHandler (runReader lowerBound) - . fmap toList + . fmap (toList @B) . raiseHandler runNonDet data B a = E | L a | B (B a) (B a) diff --git a/src/Analysis/Abstract/Caching/FlowSensitive.hs b/src/Analysis/Abstract/Caching/FlowSensitive.hs index 5adadf611..226aef748 100644 --- a/src/Analysis/Abstract/Caching/FlowSensitive.hs +++ b/src/Analysis/Abstract/Caching/FlowSensitive.hs @@ -82,7 +82,7 @@ convergingModules :: ( Cacheable term address value , Carrier sig m , Alternative m ) - => (Module (Either prelude term) -> Evaluator term address value (AltC Maybe m) value) + => (Module (Either prelude term) -> Evaluator term address value (NonDetC m) value) -> (Module (Either prelude term) -> Evaluator term address value m value) convergingModules recur m@(Module _ (Left _)) = raiseHandler runNonDet (recur m) >>= maybeM empty convergingModules recur m@(Module _ (Right term)) = do @@ -97,7 +97,7 @@ convergingModules recur m@(Module _ (Right term)) = do -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - withOracle prevCache (raiseHandler runNonDet (recur m))) + withOracle prevCache (raiseHandler (runNonDet @Maybe) (recur m))) maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. @@ -126,7 +126,8 @@ getConfiguration :: (Member (Reader (Live address)) sig, Member (State (Heap add getConfiguration term = Configuration term <$> askRoots <*> getHeap -caching :: Evaluator term address value (AltC [] +caching :: Monad m + => Evaluator term address value ( NonDetC (ReaderC (Cache term address value) (StateC (Cache term address value) m))) a diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 7914e6cc8..960576616 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -160,8 +160,8 @@ instance ( Carrier sig m traceM "ifthenelse" ifthenelse cond' (Evaluator body *> continue) (pure Unit)))) (\case - Resumable (BaseError _ _ (UnspecializedError _)) _ -> throwError (Abort @(Value term address)) - Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> throwError (Abort @(Value term address))) + Resumable (BaseError _ _ (UnspecializedError _)) _ -> traceM "unspecialized" *> throwError (Abort @(Value term address)) + Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> traceM "refun" *> throwError (Abort @(Value term address))) k res diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index e9860ba3f..cd80aeb82 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -210,8 +210,7 @@ checking (ReaderC (Live Monovariant) - (AltC - [] + (NonDetC (ReaderC (Cache term @@ -659,7 +658,7 @@ evaluateProjectWithCaching :: ( term ~ Term (Sum syntax) Location (ResumableC (BaseError (UnspecializedError Monovariant Type)) (ResumableC (BaseError (LoadError Monovariant Type)) (ReaderC (Live Monovariant) - (AltC [] + (NonDetC (ReaderC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type) (StateC (Analysis.Abstract.Caching.FlowSensitive.Cache (Data.Quieterm.Quieterm (Sum syntax) Data.Location.Location) Monovariant Type) (FreshC diff --git a/vendor/fused-effects b/vendor/fused-effects index 9bbf58dd7..17b0a846a 160000 --- a/vendor/fused-effects +++ b/vendor/fused-effects @@ -1 +1 @@ -Subproject commit 9bbf58dd7d87a3d89c9698abdcf9e52b6effbaf0 +Subproject commit 17b0a846aa50fd0dea157624c031a550d8edd469 From 2784f14c51df9abad6c22abc3028ed48be53c84b Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 6 Mar 2019 18:13:39 -0500 Subject: [PATCH 28/32] Rob is the brain genious --- src/Analysis/Abstract/Dead.hs | 19 ++++++++++--------- src/Analysis/Abstract/Tracing.hs | 18 ++++++++++++------ src/Data/Abstract/Value/Concrete.hs | 18 ++++++++---------- 3 files changed, 30 insertions(+), 25 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index ae7aee828..984c910d3 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -32,20 +32,21 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term revivingTerms :: ( Member (State (Dead term)) sig - , Ord term - , Carrier sig m - ) + , Ord term + , Carrier sig m + ) => Open (term -> Evaluator term address value m a) revivingTerms recur term = revive term *> recur term killingModules :: ( Foldable (Base term) - , Member (State (Dead term)) sig - , Ord term - , Recursive term - , Carrier sig m - ) + , Member (State (Dead term)) sig + , Ord term + , Recursive term + , Carrier sig m + ) => Open (Module term -> Evaluator term address value m a) killingModules recur m = killAll (subterms (moduleBody m)) *> recur m -providingDeadSet :: (Carrier sig m, Effect sig) => Evaluator term address value (StateC (Dead term) (Evaluator term address value m)) a -> Evaluator term address value m (Dead term, a) +providingDeadSet :: Evaluator term address value (StateC (Dead term) (Evaluator term address value m)) a + -> Evaluator term address value m (Dead term, a) providingDeadSet = runState lowerBound . runEvaluator diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 0e9963d55..e2643164a 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -12,18 +12,24 @@ import Data.Semigroup.Reducer as Reducer -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. tracingTerms :: ( Member (State (Heap address address value)) sig - , Member (Writer (trace (Configuration term address value))) sig - , Carrier sig m - , Reducer (Configuration term address value) (trace (Configuration term address value)) - ) + , Member (Writer (trace (Configuration term address value))) sig + , Carrier sig m + , Reducer (Configuration term address value) (trace (Configuration term address value)) + ) => trace (Configuration term address value) -> Open (term -> Evaluator term address value m a) tracingTerms proxy recur term = getConfiguration term >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term -trace :: (Member (Writer (trace (Configuration term address value))) sig, Carrier sig m) => trace (Configuration term address value) -> Evaluator term address value m () +trace :: ( Member (Writer (trace (Configuration term address value))) sig + , Carrier sig m + ) + => trace (Configuration term address value) + -> Evaluator term address value m () trace = tell -tracing :: (Monoid (trace (Configuration term address value)), Carrier sig m, Effect sig) => Evaluator term address value (WriterC (trace (Configuration term address value)) (Evaluator term address value m)) a -> Evaluator term address value m (trace (Configuration term address value), a) +tracing :: (Monoid (trace (Configuration term address value))) + => Evaluator term address value (WriterC (trace (Configuration term address value)) (Evaluator term address value m)) a + -> Evaluator term address value m (trace (Configuration term address value), a) tracing = runWriter . runEvaluator diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index 960576616..56c328222 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -143,26 +143,24 @@ instance ( Carrier sig m eff (R other) = WhileC . eff . handleCoercible $ other eff (L (Abstract.While cond body k)) = do - let loop x = catchLoopControl (fix x) $ \case - Break value -> let foo = pure value in traceM "Break" *> foo - Abort -> traceM "abort" *> pure Unit + let loop x = catchError x $ \case + Break value -> pure value + Abort -> pure Unit -- FIXME: Figure out how to deal with this. Ruby treats this as the result -- of the current block iteration, while PHP specifies a breakout level -- and TypeScript appears to take a label. - Continue _ -> traceM "Continue" *> loop x + Continue _ -> loop x - res <- interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (runEvaluator (loop (\continue -> do - cond' <- Evaluator cond + interpose @(Resumable (BaseError (UnspecializedError address (Value term address)))) (loop (do + cond' <- cond -- `interpose` is used to handle 'UnspecializedError's and abort out of the -- loop, otherwise under concrete semantics we run the risk of the -- conditional always being true and getting stuck in an infinite loop. - traceM "ifthenelse" - ifthenelse cond' (Evaluator body *> continue) (pure Unit)))) + ifthenelse cond' (body *> throwError (Continue @(Value term address) Unit)) (pure Unit))) (\case Resumable (BaseError _ _ (UnspecializedError _)) _ -> traceM "unspecialized" *> throwError (Abort @(Value term address)) - Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> traceM "refun" *> throwError (Abort @(Value term address))) - k res + Resumable (BaseError _ _ (RefUnspecializedError _)) _ -> traceM "refun" *> throwError (Abort @(Value term address))) >>= k From 8cbd955629f9576bff4aa609759f2e332970a13c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 7 Mar 2019 07:30:59 -0500 Subject: [PATCH 29/32] lint --- src/Analysis/Abstract/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 310f75666..59f2fbce8 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DerivingVia, GeneralizedNewtypeDeriving, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DerivingVia, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Graph ( Graph(..) , ControlFlowVertex(..) From aac0dccb4f8a53b1804a5890f8ce1497eceb0898 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 7 Mar 2019 09:25:13 -0500 Subject: [PATCH 30/32] lints again --- src/Analysis/Abstract/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 59f2fbce8..ca1249d6d 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/src/Analysis/Abstract/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DerivingVia, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DerivingVia, LambdaCase, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Graph ( Graph(..) , ControlFlowVertex(..) From c1d9ea8a926b7cd6c40f3d71a6f0913f8745df5b Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 7 Mar 2019 13:55:15 -0500 Subject: [PATCH 31/32] Bump license version. --- .licenses/semantic/cabal/fused-effects.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.licenses/semantic/cabal/fused-effects.txt b/.licenses/semantic/cabal/fused-effects.txt index b3407a5b0..b7fb644fb 100644 --- a/.licenses/semantic/cabal/fused-effects.txt +++ b/.licenses/semantic/cabal/fused-effects.txt @@ -1,7 +1,7 @@ --- type: cabal name: fused-effects -version: 0.1.2.1 +version: 0.2.0.1 summary: A fast, flexible, fused effect system. homepage: https://github.com/robrix/fused-effects license: bsd-3-clause @@ -34,4 +34,4 @@ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. From b324cb8c61d7e432ae80a25828fa400363cd22e9 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Sat, 9 Mar 2019 14:54:30 -0500 Subject: [PATCH 32/32] Fix missing quotes. --- .licenses/semantic/cabal/semigroupoids.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.licenses/semantic/cabal/semigroupoids.txt b/.licenses/semantic/cabal/semigroupoids.txt index 6d48a2e02..4f22fc668 100644 --- a/.licenses/semantic/cabal/semigroupoids.txt +++ b/.licenses/semantic/cabal/semigroupoids.txt @@ -2,7 +2,7 @@ type: cabal name: semigroupoids version: 5.3.2 -summary: Semigroupoids: Category sans id +summary: 'Semigroupoids: Category sans id' homepage: https://github.com/ekmett/semigroupoids license: bsd-2-clause ---