From 0254ad676a14e3d5a7dc863b25ec4477f57023f8 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 23 May 2018 14:23:31 -0400 Subject: [PATCH 01/10] WIP: this works, but doesn't bracket or rethrow correctly. --- src/Parsing/TreeSitter.hs | 20 ++++++++++++++------ src/Semantic/IO.hs | 25 +++++++++++++++++++++++++ src/Semantic/Task.hs | 4 ++-- 3 files changed, 41 insertions(+), 8 deletions(-) diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index d81c7876f..4e12b891a 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -8,6 +8,8 @@ import Prologue import Control.Concurrent.Async import Control.Monad +import Control.Monad.Effect +import Control.Monad.IO.Class import Data.AST (AST, Node (Node)) import Data.Blob import Data.ByteString.Unsafe (unsafeUseAsCStringLen) @@ -27,6 +29,10 @@ import qualified TreeSitter.Tree as TS newtype Timeout = Milliseconds Int +data ParseException = TimedOut deriving (Show, Typeable) + +instance Exception ParseException + -- Change this to putStrLn if you want to debug the locking/cancellation code. -- TODO: Someday we should run this all in Eff so that we can 'trace'. dbg :: String -> IO () @@ -49,13 +55,14 @@ runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ then pure Nothing else do TS.ts_tree_root_node_p treePtr rootPtr - fmap Just (peek rootPtr >>= anaM toAST) + ptr <- peek rootPtr + runM (fmap Just (anaM toAST ptr)) bracket acquire release go) -- | Parse 'Source' with the given 'TS.Language' and return its AST. -- Returns Nothing if the operation timed out. -parseToAST :: (Bounded grammar, Enum grammar) => Timeout -> Ptr TS.Language -> Blob -> IO (Maybe (AST [] grammar)) -parseToAST (Milliseconds s) language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do +parseToAST :: (Bounded grammar, Enum grammar, Members '[Exc SomeException, IO] effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar)) +parseToAST (Milliseconds s) language Blob{..} = liftIO $ bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do let parserTimeout = s * 1000 TS.ts_parser_halt_on_error parser (CBool 1) @@ -68,13 +75,14 @@ parseToAST (Milliseconds s) language Blob{..} = bracket TS.ts_parser_new TS.ts_p -- If we get a Nothing back, then we failed, so we need to disable the parser, which -- will let the call to runParser terminate, cleaning up appropriately - when (isNothing res) (TS.ts_parser_set_enabled parser (CBool 0)) + when (isNothing res) $ + TS.ts_parser_set_enabled parser (CBool 0) pure (join res) -toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node) -toAST node@TS.Node{..} = do +toAST :: forall grammar effects . (Bounded grammar, Enum grammar, Member IO effects) => TS.Node -> Eff effects (Base (AST [] grammar) TS.Node) +toAST node@TS.Node{..} = liftIO $ do let count = fromIntegral nodeChildCount children <- allocaArray count $ \ childNodesPtr -> do _ <- with nodeTSNode (\ nodePtr -> TS.ts_node_copy_child_nodes nodePtr childNodesPtr (fromIntegral count)) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 76131337c..c6cd40d8e 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -274,6 +274,31 @@ catchException :: ( Exc.Exception e -> Eff r a catchException m handler = interpose pure (\ m yield -> send (Exc.try m) >>= either handler yield) m +-- type Arrow m (effects :: [* -> *]) a b = a -> m effects b +-- raiseHandler :: Effectful m => (Eff effectsA a -> Eff effectsB b) -> m effectsA a -> m effectsB b +-- send :: (Effectful m, Member eff e) => eff b -> m e b +-- interpose :: (Member eff e, Effectful m) +-- => Arrow m e a b +-- -> (forall v. eff v -> Arrow m e v b -> m e b) +-- -> m e a -> m e b + +masking :: Member IO r => Eff r a -> Eff r a +masking = interpose pure $ \m yield -> do + res <- send (Exc.mask_ m) + yield res + +bracket' :: (Members [Exc SomeException, IO] r) + => Eff r a + -> (a -> Eff r b) + -> (a -> Eff r c) + -> Eff r c +bracket' before after thing = do + a <- before + r <- thing a `catchError` (\(SomeException e) -> after a *> throwError (SomeException e)) + r <$ after a + + + -- | Lift an 'IO' action into 'Eff', catching and rethrowing any exceptions it throws into an 'Exc' effect. rethrowing :: ( Member (Exc SomeException) r , Member IO r diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 20132f7a9..08562da47 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -194,8 +194,8 @@ defaultTimeout = Milliseconds 5000 runParser :: Members '[Reader Options, Telemetry, Exc SomeException, IO, Trace] effs => Blob -> Parser term -> Eff effs term runParser blob@Blob{..} parser = case parser of ASTParser language -> - time "parse.tree_sitter_ast_parse" languageTag $ - IO.rethrowing (parseToAST defaultTimeout language blob) + time "parse.tree_sitter_ast_parse" languageTag $ do + parseToAST defaultTimeout language blob >>= maybeM (throwError (SomeException ParserTimedOut)) AssignmentParser parser assignment -> do From 6bd6e71d75c8822e77fb6a6ea416fdc7b656b2db Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 25 May 2018 11:37:16 -0400 Subject: [PATCH 02/10] Implement a correct bracket. --- src/Parsing/TreeSitter.hs | 20 +++++++-- src/Semantic/IO.hs | 86 ++++++++++++++------------------------- 2 files changed, 48 insertions(+), 58 deletions(-) diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index 4e12b891a..a56267f80 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -4,9 +4,10 @@ module Parsing.TreeSitter , parseToAST ) where -import Prologue +import Prologue hiding (catchError, throwError) import Control.Concurrent.Async +import Control.Exception (throwIO) import Control.Monad import Control.Monad.Effect import Control.Monad.IO.Class @@ -20,6 +21,7 @@ import Data.Term import Foreign import Foreign.C.Types (CBool (..)) import Foreign.Marshal.Array (allocaArray) +import Semantic.IO hiding (Source) import System.Timeout import qualified TreeSitter.Language as TS @@ -59,10 +61,22 @@ runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ runM (fmap Just (anaM toAST ptr)) bracket acquire release go) +-- | The semantics of @bracket before after handler@ are as follows: +-- * Exceptions in @before@ and @after@ are thrown in IO. +-- * @after@ is called on IO exceptions in @handler@, and then rethrown in IO. +-- * If @handler@ completes successfully, @after@ is called +-- Call 'catchException' at the call site if you want to recover. +bracket' :: (Member IO r) => IO a -> (a -> IO b) -> (a -> Eff r c) -> Eff r c +bracket' before after action = do + a <- liftIO before + let cleanup = liftIO (after a) + res <- action a `catchException` (\(e :: SomeException) -> cleanup >> liftIO (throwIO e)) + res <$ cleanup + -- | Parse 'Source' with the given 'TS.Language' and return its AST. -- Returns Nothing if the operation timed out. -parseToAST :: (Bounded grammar, Enum grammar, Members '[Exc SomeException, IO] effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar)) -parseToAST (Milliseconds s) language Blob{..} = liftIO $ bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do +parseToAST :: (Bounded grammar, Enum grammar, Member IO effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar)) +parseToAST (Milliseconds s) language Blob{..} = bracket' TS.ts_parser_new TS.ts_parser_delete $ \ parser -> liftIO $ do let parserTimeout = s * 1000 TS.ts_parser_halt_on_error parser (CBool 1) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index c6cd40d8e..6e9a1f43c 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -1,35 +1,36 @@ {-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.IO -( readFile -, readFilePair -, isDirectory -, readBlobPairsFromHandle -, readBlobsFromHandle -, readProjectFromPaths -, readBlobsFromDir -, findFiles -, languageForFilePath -, NoLanguageForBlob(..) -, noLanguageForBlob -, readBlob -, readBlobs -, readBlobPairs -, readProject -, findFilesInDir -, write -, Handle(..) -, getHandle -, IO.IOMode(..) -, stdin -, stdout -, stderr -, openFileForReading -, Source(..) -, Destination(..) -, Files -, runFiles -, rethrowing -) where + ( Destination(..) + , Files + , Handle(..) + , IO.IOMode(..) + , NoLanguageForBlob(..) + , Source(..) + , catchException + , findFiles + , findFilesInDir + , getHandle + , isDirectory + , languageForFilePath + , noLanguageForBlob + , openFileForReading + , readBlob + , readBlobPairs + , readBlobPairsFromHandle + , readBlobs + , readBlobsFromDir + , readBlobsFromHandle + , readFile + , readFilePair + , readProject + , readProjectFromPaths + , rethrowing + , runFiles + , stderr + , stdin + , stdout + , write + ) where import qualified Control.Exception as Exc import Control.Monad.Effect @@ -274,31 +275,6 @@ catchException :: ( Exc.Exception e -> Eff r a catchException m handler = interpose pure (\ m yield -> send (Exc.try m) >>= either handler yield) m --- type Arrow m (effects :: [* -> *]) a b = a -> m effects b --- raiseHandler :: Effectful m => (Eff effectsA a -> Eff effectsB b) -> m effectsA a -> m effectsB b --- send :: (Effectful m, Member eff e) => eff b -> m e b --- interpose :: (Member eff e, Effectful m) --- => Arrow m e a b --- -> (forall v. eff v -> Arrow m e v b -> m e b) --- -> m e a -> m e b - -masking :: Member IO r => Eff r a -> Eff r a -masking = interpose pure $ \m yield -> do - res <- send (Exc.mask_ m) - yield res - -bracket' :: (Members [Exc SomeException, IO] r) - => Eff r a - -> (a -> Eff r b) - -> (a -> Eff r c) - -> Eff r c -bracket' before after thing = do - a <- before - r <- thing a `catchError` (\(SomeException e) -> after a *> throwError (SomeException e)) - r <$ after a - - - -- | Lift an 'IO' action into 'Eff', catching and rethrowing any exceptions it throws into an 'Exc' effect. rethrowing :: ( Member (Exc SomeException) r , Member IO r From b2aa29e6c6b1254afc5b53bae095f19db7604d6c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 25 May 2018 12:28:56 -0400 Subject: [PATCH 03/10] :fire: dbg and just use `trace`. --- src/Parsing/TreeSitter.hs | 55 +++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 28 deletions(-) diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index a56267f80..ee2d8fe99 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -4,12 +4,14 @@ module Parsing.TreeSitter , parseToAST ) where -import Prologue hiding (catchError, throwError) +import Prologue import Control.Concurrent.Async +import Control.Concurrent.MVar import Control.Exception (throwIO) import Control.Monad import Control.Monad.Effect +import Control.Monad.Effect.Trace import Control.Monad.IO.Class import Data.AST (AST, Node (Node)) import Data.Blob @@ -31,34 +33,28 @@ import qualified TreeSitter.Tree as TS newtype Timeout = Milliseconds Int -data ParseException = TimedOut deriving (Show, Typeable) +data Result grammar + = Failed + | Succeeded (AST [] grammar) -instance Exception ParseException - --- Change this to putStrLn if you want to debug the locking/cancellation code. --- TODO: Someday we should run this all in Eff so that we can 'trace'. -dbg :: String -> IO () -dbg = const (pure ()) - -runParser :: (Enum grammar, Bounded grammar) => Ptr TS.Parser -> Source -> IO (Maybe (AST [] grammar)) -runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> +runParser :: (Enum grammar, Bounded grammar) => Ptr TS.Parser -> Source -> IO (Result grammar) +runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> do alloca (\ rootPtr -> do let acquire = do - dbg "Starting parse" -- Change this to TS.ts_parser_loop_until_cancelled if you want to test out cancellation TS.ts_parser_parse_string parser nullPtr source len let release t - | t == nullPtr = dbg "Parse failed" - | otherwise = dbg "Parse completed" *> TS.ts_tree_delete t + | t == nullPtr = pure () + | otherwise = TS.ts_tree_delete t let go treePtr = do if treePtr == nullPtr - then pure Nothing + then pure Failed else do TS.ts_tree_root_node_p treePtr rootPtr ptr <- peek rootPtr - runM (fmap Just (anaM toAST ptr)) + runM (fmap Succeeded (anaM toAST ptr)) bracket acquire release go) -- | The semantics of @bracket before after handler@ are as follows: @@ -75,24 +71,27 @@ bracket' before after action = do -- | Parse 'Source' with the given 'TS.Language' and return its AST. -- Returns Nothing if the operation timed out. -parseToAST :: (Bounded grammar, Enum grammar, Member IO effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar)) -parseToAST (Milliseconds s) language Blob{..} = bracket' TS.ts_parser_new TS.ts_parser_delete $ \ parser -> liftIO $ do +parseToAST :: (Bounded grammar, Enum grammar, Members '[Trace, IO] effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar)) +parseToAST (Milliseconds s) language Blob{..} = bracket' TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do let parserTimeout = s * 1000 - TS.ts_parser_halt_on_error parser (CBool 1) - TS.ts_parser_set_language parser language + liftIO $ do + TS.ts_parser_halt_on_error parser (CBool 1) + TS.ts_parser_set_language parser language - parsing <- async (runParser parser blobSource) + trace "tree-sitter: beginning parsing" + + parsing <- liftIO . async $ runParser parser blobSource -- Kick the parser off asynchronously and wait according to the provided timeout. - res <- timeout parserTimeout (wait parsing) + res <- liftIO . timeout parserTimeout $ wait parsing - -- If we get a Nothing back, then we failed, so we need to disable the parser, which - -- will let the call to runParser terminate, cleaning up appropriately - when (isNothing res) $ - TS.ts_parser_set_enabled parser (CBool 0) - - pure (join res) + case res of + Just Failed -> Nothing <$ trace "tree-sitter: parsing failed" + Just (Succeeded ast) -> Just ast <$ trace "tree-sitter: parsing succeeded" + Nothing -> do + trace "tree-sitter: parsing timed out" + Nothing <$ liftIO (TS.ts_parser_set_enabled parser (CBool 0)) toAST :: forall grammar effects . (Bounded grammar, Enum grammar, Member IO effects) => TS.Node -> Eff effects (Base (AST [] grammar) TS.Node) From 3e02366d143ff512433013a040ce8998a66059ff Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 25 May 2018 12:34:04 -0400 Subject: [PATCH 04/10] don't use Eff in `toAST` since it's just being called from IO. --- src/Parsing/TreeSitter.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index ee2d8fe99..8b7b327ed 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -54,7 +54,7 @@ runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ else do TS.ts_tree_root_node_p treePtr rootPtr ptr <- peek rootPtr - runM (fmap Succeeded (anaM toAST ptr)) + Succeeded <$> anaM toAST ptr bracket acquire release go) -- | The semantics of @bracket before after handler@ are as follows: @@ -94,8 +94,8 @@ parseToAST (Milliseconds s) language Blob{..} = bracket' TS.ts_parser_new TS.ts_ Nothing <$ liftIO (TS.ts_parser_set_enabled parser (CBool 0)) -toAST :: forall grammar effects . (Bounded grammar, Enum grammar, Member IO effects) => TS.Node -> Eff effects (Base (AST [] grammar) TS.Node) -toAST node@TS.Node{..} = liftIO $ do +toAST :: forall grammar effects . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node) +toAST node@TS.Node{..} = do let count = fromIntegral nodeChildCount children <- allocaArray count $ \ childNodesPtr -> do _ <- with nodeTSNode (\ nodePtr -> TS.ts_node_copy_child_nodes nodePtr childNodesPtr (fromIntegral count)) From bec56ece821e8b3052c4b3d33081d58ce3a86206 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 25 May 2018 12:35:16 -0400 Subject: [PATCH 05/10] otiose 'do' --- src/Semantic/Task.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 08562da47..406df5bfd 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -194,7 +194,7 @@ defaultTimeout = Milliseconds 5000 runParser :: Members '[Reader Options, Telemetry, Exc SomeException, IO, Trace] effs => Blob -> Parser term -> Eff effs term runParser blob@Blob{..} parser = case parser of ASTParser language -> - time "parse.tree_sitter_ast_parse" languageTag $ do + time "parse.tree_sitter_ast_parse" languageTag $ parseToAST defaultTimeout language blob >>= maybeM (throwError (SomeException ParserTimedOut)) From 9b68986a93ddae7554f9915cedf991381dd7212b Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 25 May 2018 12:36:48 -0400 Subject: [PATCH 06/10] warnings --- src/Parsing/TreeSitter.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index 8b7b327ed..20e4a3ead 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -7,9 +7,7 @@ module Parsing.TreeSitter import Prologue import Control.Concurrent.Async -import Control.Concurrent.MVar import Control.Exception (throwIO) -import Control.Monad import Control.Monad.Effect import Control.Monad.Effect.Trace import Control.Monad.IO.Class @@ -94,7 +92,7 @@ parseToAST (Milliseconds s) language Blob{..} = bracket' TS.ts_parser_new TS.ts_ Nothing <$ liftIO (TS.ts_parser_set_enabled parser (CBool 0)) -toAST :: forall grammar effects . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node) +toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node) toAST node@TS.Node{..} = do let count = fromIntegral nodeChildCount children <- allocaArray count $ \ childNodesPtr -> do From 18723b2c1e4cc42dafda4b837cef77c6fd8f989f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 25 May 2018 13:02:03 -0400 Subject: [PATCH 07/10] dedent import list --- src/Semantic/IO.hs | 62 +++++++++++++++++++++++----------------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 6e9a1f43c..a4ccd5314 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -1,36 +1,36 @@ {-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.IO - ( Destination(..) - , Files - , Handle(..) - , IO.IOMode(..) - , NoLanguageForBlob(..) - , Source(..) - , catchException - , findFiles - , findFilesInDir - , getHandle - , isDirectory - , languageForFilePath - , noLanguageForBlob - , openFileForReading - , readBlob - , readBlobPairs - , readBlobPairsFromHandle - , readBlobs - , readBlobsFromDir - , readBlobsFromHandle - , readFile - , readFilePair - , readProject - , readProjectFromPaths - , rethrowing - , runFiles - , stderr - , stdin - , stdout - , write - ) where +( Destination(..) +, Files +, Handle(..) +, IO.IOMode(..) +, NoLanguageForBlob(..) +, Source(..) +, catchException +, findFiles +, findFilesInDir +, getHandle +, isDirectory +, languageForFilePath +, noLanguageForBlob +, openFileForReading +, readBlob +, readBlobPairs +, readBlobPairsFromHandle +, readBlobs +, readBlobsFromDir +, readBlobsFromHandle +, readFile +, readFilePair +, readProject +, readProjectFromPaths +, rethrowing +, runFiles +, stderr +, stdin +, stdout +, write +) where import qualified Control.Exception as Exc import Control.Monad.Effect From 8f183d5f8641fb3c4ff20858a5425c0590faffd6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 25 May 2018 15:13:41 -0400 Subject: [PATCH 08/10] Represent Value as a normal ADT. --- src/Data/Abstract/Value.hs | 305 +++++++++---------------------------- 1 file changed, 71 insertions(+), 234 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 43e8c72cc..a585dc7c4 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -11,198 +11,35 @@ import Data.Scientific (Scientific) import Data.Scientific.Exts import Data.Semigroup.Reducer import qualified Data.Set as Set -import Data.Sum -import Prologue hiding (TypeError, project) -import Prelude hiding (Float, Integer, String, Rational) -import qualified Prelude +import Prologue -type ValueConstructors location - = '[Array - , Boolean - , Class location - , Closure location - , Float - , Hash - , Integer - , KVPair - , Namespace location - , Null - , Rational - , String - , Symbol - , Tuple - , Unit - , Hole - ] - --- | Open union of primitive values that terms can be evaluated to. --- Fix by another name. -newtype Value location = Value (Sum (ValueConstructors location) (Value location)) +data Value location + = Closure PackageInfo ModuleInfo [Name] Label (Environment location) + | Unit + | Boolean Bool + | Integer (Number.Number Integer) + | Rational (Number.Number Rational) + | Float (Number.Number Scientific) + | String ByteString + | Symbol ByteString + | Tuple [Value location] + | Array [Value location] + | Class Name (Environment location) + | Namespace Name (Environment location) + | KVPair (Value location) (Value location) + | Hash [Value location] + | Null + | Hole deriving (Eq, Show, Ord) --- | Identical to 'inject', but wraps the resulting sub-entity in a 'Value'. -injValue :: (f :< ValueConstructors location) => f (Value location) -> Value location -injValue = Value . inject - --- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper. -prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location)) -prjValue (Value v) = project v - --- | Convenience function for projecting two values. -prjPair :: (f :< ValueConstructors location , g :< ValueConstructors location) - => (Value location, Value location) - -> Maybe (f (Value location), g (Value location)) -prjPair = bitraverse prjValue prjValue - --- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. - --- | A function value consisting of a package & module info, a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body. -data Closure location value = Closure PackageInfo ModuleInfo [Name] Label (Environment location) - deriving (Eq, Generic1, Ord, Show) - -instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq -instance Ord location => Ord1 (Closure location) where liftCompare = genericLiftCompare -instance Show location => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec - --- | The unit value. Typically used to represent the result of imperative statements. -data Unit value = Unit - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Unit where liftEq = genericLiftEq -instance Ord1 Unit where liftCompare = genericLiftCompare -instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec - -data Hole value = Hole - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Hole where liftEq = genericLiftEq -instance Ord1 Hole where liftCompare = genericLiftCompare -instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec - --- | Boolean values. -newtype Boolean value = Boolean { getBoolean :: Bool } - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Boolean where liftEq = genericLiftEq -instance Ord1 Boolean where liftCompare = genericLiftCompare -instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec - --- | Arbitrary-width integral values. -newtype Integer value = Integer (Number.Number Prelude.Integer) - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Integer where liftEq = genericLiftEq -instance Ord1 Integer where liftCompare = genericLiftCompare -instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec - --- | Arbitrary-width rational values values. -newtype Rational value = Rational (Number.Number Prelude.Rational) - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Rational where liftEq = genericLiftEq -instance Ord1 Rational where liftCompare = genericLiftCompare -instance Show1 Rational where liftShowsPrec = genericLiftShowsPrec - --- | String values. -newtype String value = String ByteString - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 String where liftEq = genericLiftEq -instance Ord1 String where liftCompare = genericLiftCompare -instance Show1 String where liftShowsPrec = genericLiftShowsPrec - --- | Possibly-interned Symbol values. --- TODO: Should this store a 'Text'? -newtype Symbol value = Symbol ByteString - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Symbol where liftEq = genericLiftEq -instance Ord1 Symbol where liftCompare = genericLiftCompare -instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec - --- | Float values. -newtype Float value = Float (Number.Number Scientific) - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Float where liftEq = genericLiftEq -instance Ord1 Float where liftCompare = genericLiftCompare -instance Show1 Float where liftShowsPrec = genericLiftShowsPrec - --- | Zero or more values. Fixed-size at interpretation time. --- TODO: Investigate whether we should use Vector for this. --- TODO: Should we have a Some type over a nonemmpty list? Or does this merit one? -newtype Tuple value = Tuple [value] - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Tuple where liftEq = genericLiftEq -instance Ord1 Tuple where liftCompare = genericLiftCompare -instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec - --- | Zero or more values. Dynamically resized as needed at interpretation time. --- TODO: Vector? Seq? -newtype Array value = Array [value] - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Array where liftEq = genericLiftEq -instance Ord1 Array where liftCompare = genericLiftCompare -instance Show1 Array where liftShowsPrec = genericLiftShowsPrec - --- | Class values. There will someday be a difference between classes and objects, --- but for the time being we're pretending all languages have prototypical inheritance. -data Class location value = Class - { _className :: Name - , _classScope :: Environment location - } deriving (Eq, Generic1, Ord, Show) - -instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq -instance Ord location => Ord1 (Class location) where liftCompare = genericLiftCompare -instance Show location => Show1 (Class location) where liftShowsPrec = genericLiftShowsPrec - -data Namespace location value = Namespace - { namespaceName :: Name - , namespaceScope :: Environment location - } deriving (Eq, Generic1, Ord, Show) - -instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq -instance Ord location => Ord1 (Namespace location) where liftCompare = genericLiftCompare -instance Show location => Show1 (Namespace location) where liftShowsPrec = genericLiftShowsPrec - -data KVPair value = KVPair value value - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 KVPair where liftEq = genericLiftEq -instance Ord1 KVPair where liftCompare = genericLiftCompare -instance Show1 KVPair where liftShowsPrec = genericLiftShowsPrec - --- You would think this would be a @Map value value@ or a @[(value, value)]. --- You would be incorrect, as we can't derive a Generic1 instance for the above, --- and in addition a 'Map' representation would lose information given hash literals --- that assigned multiple values to one given key. Instead, this holds KVPair --- values. The smart constructor for hashes in 'AbstractValue' ensures that these are --- only populated with pairs. -newtype Hash value = Hash [value] - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Hash where liftEq = genericLiftEq -instance Ord1 Hash where liftCompare = genericLiftCompare -instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec - -data Null value = Null - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Null where liftEq = genericLiftEq -instance Ord1 Null where liftCompare = genericLiftCompare -instance Show1 Null where liftShowsPrec = genericLiftShowsPrec - - instance Ord location => ValueRoots location (Value location) where valueRoots v - | Just (Closure _ _ _ _ env) <- prjValue v = Env.addresses env - | otherwise = mempty + | Closure _ _ _ _ env <- v = Env.addresses env + | otherwise = mempty instance AbstractHole (Value location) where - hole = injValue Hole + hole = Hole instance ( Members '[ Allocator location (Value location) , Reader (Environment location) @@ -222,11 +59,11 @@ instance ( Members '[ Allocator location (Value location) packageInfo <- currentPackage moduleInfo <- currentModule l <- label body - injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv + Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv call op params = do - case prjValue op of - Just (Closure packageInfo moduleInfo names label env) -> do + case op of + Closure packageInfo moduleInfo names label env -> do body <- goto label -- Evaluate the bindings and body with the closure’s package/module info in scope in order to -- charge them to the closure's origin. @@ -237,7 +74,7 @@ instance ( Members '[ Allocator location (Value location) assign a v Env.insert name a <$> rest) (pure env) (zip names params) localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value) - Nothing -> throwValueError (CallError op) + _ -> throwValueError (CallError op) -- | Construct a 'Value' wrapping the value arguments (if any). @@ -256,51 +93,51 @@ instance ( Members '[ Allocator location (Value location) , Show location ) => AbstractValue location (Value location) (Goto effects (Value location) ': effects) where - unit = pure . injValue $ Unit - integer = pure . injValue . Integer . Number.Integer - boolean = pure . injValue . Boolean - string = pure . injValue . String - float = pure . injValue . Float . Number.Decimal - symbol = pure . injValue . Symbol - rational = pure . injValue . Rational . Number.Ratio + unit = pure $ Unit + integer = pure . Integer . Number.Integer + boolean = pure . Boolean + string = pure . String + float = pure . Float . Number.Decimal + symbol = pure . Symbol + rational = pure . Rational . Number.Ratio - multiple = pure . injValue . Tuple - array = pure . injValue . Array + multiple = pure . Tuple + array = pure . Array - kvPair k = pure . injValue . KVPair k + kvPair k = pure . KVPair k - null = pure . injValue $ Null + null = pure $ Null asPair val - | Just (KVPair k v) <- prjValue val = pure (k, v) + | KVPair k v <- val = pure (k, v) | otherwise = throwValueError $ KeyValueError val - hash = pure . injValue . Hash . fmap (injValue . uncurry KVPair) + hash = pure . Hash . map (uncurry KVPair) - klass n [] env = pure . injValue $ Class n env + klass n [] env = pure $ Class n env klass n supers env = do product <- foldl mergeEnvs emptyEnv . catMaybes <$> traverse scopedEnvironment supers - pure . injValue $ Class n (mergeEnvs product env) + pure $ Class n (mergeEnvs product env) namespace n env = do maybeAddr <- lookupEnv n env' <- maybe (pure emptyEnv) (asNamespaceEnv <=< deref) maybeAddr - pure (injValue (Namespace n (Env.mergeNewer env' env))) + pure (Namespace n (Env.mergeNewer env' env)) where asNamespaceEnv v - | Just (Namespace _ env') <- prjValue v = pure env' - | otherwise = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace") + | Namespace _ env' <- v = pure env' + | otherwise = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace") scopedEnvironment o - | Just (Class _ env) <- prjValue o = pure (Just env) - | Just (Namespace _ env) <- prjValue o = pure (Just env) + | Class _ env <- o = pure (Just env) + | Namespace _ env <- o = pure (Just env) | otherwise = pure Nothing asString v - | Just (String n) <- prjValue v = pure n - | otherwise = throwValueError $ StringError v + | String n <- v = pure n + | otherwise = throwValueError $ StringError v ifthenelse cond if' else' = do - bool <- maybe (throwValueError (BoolError cond)) (pure . getBoolean) (prjValue cond) + bool <- case cond of { Boolean b -> pure b ; _ -> throwValueError (BoolError cond) } if bool then if' else else' index = go where @@ -308,26 +145,26 @@ instance ( Members '[ Allocator location (Value location) | ii > genericLength list = throwValueError (BoundsError list ii) | otherwise = pure (genericIndex list ii) go arr idx - | (Just (Array arr, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx arr i - | (Just (Tuple tup, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx tup i + | (Array arr, Integer (Number.Integer i)) <- (arr, idx) = tryIdx arr i + | (Tuple tup, Integer (Number.Integer i)) <- (arr, idx) = tryIdx tup i | otherwise = throwValueError (IndexError arr idx) liftNumeric f arg - | Just (Integer (Number.Integer i)) <- prjValue arg = integer $ f i - | Just (Float (Number.Decimal d)) <- prjValue arg = float $ f d - | Just (Rational (Number.Ratio r)) <- prjValue arg = rational $ f r + | Integer (Number.Integer i) <- arg = integer $ f i + | Float (Number.Decimal d) <- arg = float $ f d + | Rational (Number.Ratio r) <- arg = rational $ f r | otherwise = throwValueError (NumericError arg) liftNumeric2 f left right - | Just (Integer i, Integer j) <- prjPair pair = tentative f i j & specialize - | Just (Integer i, Rational j) <- prjPair pair = tentative f i j & specialize - | Just (Integer i, Float j) <- prjPair pair = tentative f i j & specialize - | Just (Rational i, Integer j) <- prjPair pair = tentative f i j & specialize - | Just (Rational i, Rational j) <- prjPair pair = tentative f i j & specialize - | Just (Rational i, Float j) <- prjPair pair = tentative f i j & specialize - | Just (Float i, Integer j) <- prjPair pair = tentative f i j & specialize - | Just (Float i, Rational j) <- prjPair pair = tentative f i j & specialize - | Just (Float i, Float j) <- prjPair pair = tentative f i j & specialize + | (Integer i, Integer j) <- pair = tentative f i j & specialize + | (Integer i, Rational j) <- pair = tentative f i j & specialize + | (Integer i, Float j) <- pair = tentative f i j & specialize + | (Rational i, Integer j) <- pair = tentative f i j & specialize + | (Rational i, Rational j) <- pair = tentative f i j & specialize + | (Rational i, Float j) <- pair = tentative f i j & specialize + | (Float i, Integer j) <- pair = tentative f i j & specialize + | (Float i, Rational j) <- pair = tentative f i j & specialize + | (Float i, Float j) <- pair = tentative f i j & specialize | otherwise = throwValueError (Numeric2Error left right) where tentative x i j = attemptUnsafeArithmetic (x i j) @@ -341,13 +178,13 @@ instance ( Members '[ Allocator location (Value location) pair = (left, right) liftComparison comparator left right - | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = go i j - | Just (Integer (Number.Integer i), Float (Number.Decimal j)) <- prjPair pair = go (fromIntegral i) j - | Just (Float (Number.Decimal i), Integer (Number.Integer j)) <- prjPair pair = go i (fromIntegral j) - | Just (Float (Number.Decimal i), Float (Number.Decimal j)) <- prjPair pair = go i j - | Just (String i, String j) <- prjPair pair = go i j - | Just (Boolean i, Boolean j) <- prjPair pair = go i j - | Just (Unit, Unit) <- prjPair pair = boolean True + | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = go i j + | (Integer (Number.Integer i), Float (Number.Decimal j)) <- pair = go (fromIntegral i) j + | (Float (Number.Decimal i), Integer (Number.Integer j)) <- pair = go i (fromIntegral j) + | (Float (Number.Decimal i), Float (Number.Decimal j)) <- pair = go i j + | (String i, String j) <- pair = go i j + | (Boolean i, Boolean j) <- pair = go i j + | (Unit, Unit) <- pair = boolean True | otherwise = throwValueError (ComparisonError left right) where -- Explicit type signature is necessary here because we're passing all sorts of things @@ -365,11 +202,11 @@ instance ( Members '[ Allocator location (Value location) liftBitwise operator target - | Just (Integer (Number.Integer i)) <- prjValue target = integer $ operator i + | Integer (Number.Integer i) <- target = integer $ operator i | otherwise = throwValueError (BitwiseError target) liftBitwise2 operator left right - | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = integer $ operator i j + | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = integer $ operator i j | otherwise = throwValueError (Bitwise2Error left right) where pair = (left, right) From ea94863148e1289daf81e7ffc0a9eb8cbb63a647 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 May 2018 08:35:33 -0400 Subject: [PATCH 09/10] Fix a couple of hints. --- src/Data/Abstract/Value.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index a585dc7c4..107140d92 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -93,7 +93,7 @@ instance ( Members '[ Allocator location (Value location) , Show location ) => AbstractValue location (Value location) (Goto effects (Value location) ': effects) where - unit = pure $ Unit + unit = pure Unit integer = pure . Integer . Number.Integer boolean = pure . Boolean string = pure . String @@ -106,7 +106,7 @@ instance ( Members '[ Allocator location (Value location) kvPair k = pure . KVPair k - null = pure $ Null + null = pure Null asPair val | KVPair k v <- val = pure (k, v) From 2993c3588c67368a6bdfe019285803b94fca07e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 28 May 2018 08:54:33 -0400 Subject: [PATCH 10/10] Correct the specs. --- test/Analysis/Python/Spec.hs | 6 +++--- test/Analysis/Ruby/Spec.hs | 22 +++++++++++----------- test/Analysis/TypeScript/Spec.hs | 2 +- test/Control/Abstract/Evaluator/Spec.hs | 4 ++-- test/SpecHelpers.hs | 11 ++++++++--- 5 files changed, 25 insertions(+), 20 deletions(-) diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index ae517e19b..657382f34 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -37,14 +37,14 @@ spec = parallel $ do it "subclasses" $ do ((res, _), _) <- evaluate "subclass.py" - res `shouldBe` Right [injValue (String "\"bar\"")] + res `shouldBe` Right [String "\"bar\""] it "handles multiple inheritance left-to-right" $ do ((res, _), _) <- evaluate "multiple_inheritance.py" - res `shouldBe` Right [injValue (String "\"foo!\"")] + res `shouldBe` Right [String "\"foo!\""] where - ns n = Just . Latest . Last . Just . injValue . Namespace n + ns n = Just . Latest . Last . Just . Namespace n addr = Address . Precise fixtures = "test/fixtures/python/analysis/" evaluate entry = evalPythonProject (fixtures <> entry) diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 7ede7371f..af5512099 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -22,7 +22,7 @@ spec = parallel $ do describe "Ruby" $ do it "evaluates require_relative" $ do ((res, state), _) <- evaluate "main.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 1))] + res `shouldBe` Right [Value.Integer (Number.Integer 1)] Env.names (environment state) `shouldContain` ["foo"] it "evaluates load" $ do @@ -36,47 +36,47 @@ spec = parallel $ do it "evaluates subclass" $ do ((res, state), _) <- evaluate "subclass.rb" - res `shouldBe` Right [injValue (String "\"\"")] + res `shouldBe` Right [String "\"\""] Env.names (environment state) `shouldContain` [ "Bar", "Foo" ] (derefQName (heap state) ("Bar" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) it "evaluates modules" $ do ((res, state), _) <- evaluate "modules.rb" - res `shouldBe` Right [injValue (String "\"\"")] + res `shouldBe` Right [String "\"\""] Env.names (environment state) `shouldContain` [ "Bar" ] it "handles break correctly" $ do ((res, _), _) <- evaluate "break.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 3))] + res `shouldBe` Right [Value.Integer (Number.Integer 3)] it "handles break correctly" $ do ((res, _), _) <- evaluate "next.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 8))] + res `shouldBe` Right [Value.Integer (Number.Integer 8)] it "calls functions with arguments" $ do ((res, _), _) <- evaluate "call.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 579))] + res `shouldBe` Right [Value.Integer (Number.Integer 579)] it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 123))] + res `shouldBe` Right [Value.Integer (Number.Integer 123)] it "has prelude" $ do ((res, _), _) <- evaluate "preluded.rb" - res `shouldBe` Right [injValue (String "\"\"")] + res `shouldBe` Right [String "\"\""] it "evaluates __LINE__" $ do ((res, _), _) <- evaluate "line.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 4))] + res `shouldBe` Right [Value.Integer (Number.Integer 4)] it "resolves builtins used in the prelude" $ do ((res, _), traces) <- evaluate "puts.rb" - res `shouldBe` Right [injValue Unit] + res `shouldBe` Right [Unit] traces `shouldContain` [ "\"hello\"" ] where - ns n = Just . Latest . Last . Just . injValue . Namespace n + ns n = Just . Latest . Last . Just . Namespace n addr = Address . Precise fixtures = "test/fixtures/ruby/analysis/" evaluate entry = evalRubyProject (fixtures <> entry) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 7558aa681..b53a93509 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -36,7 +36,7 @@ spec = parallel $ do it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.ts" - res `shouldBe` Right [injValue (Value.Float (Number.Decimal 123.0))] + res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] where fixtures = "test/fixtures/typescript/analysis/" diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 1c6a07744..b778beb9b 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -20,13 +20,13 @@ spec :: Spec spec = parallel $ do it "constructs integers" $ do (expected, _) <- evaluate (integer 123) - expected `shouldBe` Right (injValue (Value.Integer (Number.Integer 123))) + expected `shouldBe` Right (Value.Integer (Number.Integer 123)) it "calls functions" $ do (expected, _) <- evaluate $ do identity <- closure [name "x"] lowerBound (variable (name "x")) call identity [integer 123] - expected `shouldBe` Right (injValue (Value.Integer (Number.Integer 123))) + expected `shouldBe` Right (Value.Integer (Number.Integer 123)) evaluate = runM diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 9df506259..777f207c1 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -24,7 +24,7 @@ import Data.Abstract.FreeVariables as X import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X hiding (lookup) import Data.Abstract.Name as X -import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue, prjValue, runValueError) +import Data.Abstract.Value (Value(..), ValueError, runValueError) import Data.Bifunctor (first) import Data.Blob as X import Data.ByteString.Builder (toLazyByteString) @@ -92,13 +92,18 @@ testEvaluating . runTermEvaluator @_ @Precise deNamespace :: Value Precise -> Maybe (Name, [Name]) -deNamespace = fmap (namespaceName &&& Env.names . namespaceScope) . prjValue @(Namespace Precise) +deNamespace (Namespace name scope) = Just (name, Env.names scope) +deNamespace _ = Nothing + +namespaceScope :: Value Precise -> Maybe (Environment Precise) +namespaceScope (Namespace _ scope) = Just scope +namespaceScope _ = Nothing derefQName :: Heap Precise (Cell Precise) (Value Precise) -> NonEmpty Name -> Environment Precise -> Maybe (Value Precise) derefQName heap = go where go (n1 :| ns) env = Env.lookup n1 env >>= flip heapLookup heap >>= getLast . unLatest >>= case ns of [] -> Just - (n2 : ns) -> fmap namespaceScope . prjValue @(Namespace Precise) >=> go (n2 :| ns) + (n2 : ns) -> namespaceScope >=> go (n2 :| ns) newtype Verbatim = Verbatim ByteString deriving (Eq)