mirror of
https://github.com/github/semantic.git
synced 2024-12-22 14:21:31 +03:00
Collapse down to a couple of linker strategies
This commit is contained in:
Timothy Clem
parent
16a4341505
commit
d370863c41
@ -24,217 +24,186 @@ import System.FilePath.Posix
|
||||
import Data.Union
|
||||
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Debug.Trace
|
||||
|
||||
-- -- | The effects necessary for concrete interpretation.
|
||||
-- --
|
||||
-- -- NOTE: Uses a memoizing linker strategy.
|
||||
-- type Evaluating t v
|
||||
-- = '[ Fail
|
||||
-- , State (Store (LocationFor v) v)
|
||||
-- , State (EnvironmentFor v) -- Global (imperative) environment
|
||||
-- , Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
|
||||
-- , State (Linker t v)
|
||||
-- ]
|
||||
--
|
||||
-- -- | Require/import another file and return an Effect.
|
||||
-- require :: forall v term es.
|
||||
-- ( Member Fail es
|
||||
-- , Member (State (Linker term v)) es
|
||||
-- , Evaluatable es term v (Base term)
|
||||
-- , Recursive term
|
||||
-- , FreeVariables term)
|
||||
-- => term -> Eff es v
|
||||
-- require term = do
|
||||
-- let [name'] = toList (freeVariables term)
|
||||
-- let name = BC.unpack name'
|
||||
-- linker <- get @(Linker term v)
|
||||
-- maybe (evalModule linker name) pure (linkerLookupValue name linker)
|
||||
-- where
|
||||
-- evalModule linker name = case linkerLookupTerm name linker of
|
||||
-- Just m -> do
|
||||
-- v <- step @v m
|
||||
-- modify @(Linker term v) (linkerInsert name v)
|
||||
-- pure v
|
||||
-- _ -> fail ("cannot find " <> show name)
|
||||
--
|
||||
-- -- | Evaluate a term to a value.
|
||||
-- evaluate :: forall v term.
|
||||
-- ( Ord v
|
||||
-- , Ord (LocationFor v)
|
||||
-- , Evaluatable (Evaluating term v) term v (Base term)
|
||||
-- , Recursive term
|
||||
-- )
|
||||
-- => term
|
||||
-- -> Final (Evaluating term v) v
|
||||
-- evaluate = run @(Evaluating term v) . fix (const step)
|
||||
--
|
||||
-- -- | Evaluate terms and an entry point to a value.
|
||||
-- evaluates :: forall v term.
|
||||
-- ( Ord v
|
||||
-- , Ord (LocationFor v)
|
||||
-- , Evaluatable (Evaluating term v) term v (Base term)
|
||||
-- , Recursive term
|
||||
-- )
|
||||
-- => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
|
||||
-- -> (Blob, term) -- Entrypoint
|
||||
-- -> Final (Evaluating term v) v
|
||||
-- evaluates pairs = run @(Evaluating term v) . fix go
|
||||
-- where
|
||||
-- go _ (Blob{..}, t) = do
|
||||
-- put (Linker @term @v Map.empty (Map.fromList (fmap toPathActionPair pairs)))
|
||||
-- step @v t
|
||||
-- toPathActionPair (Blob{..}, t) = (dropExtensions blobPath, t)
|
||||
|
||||
|
||||
-- -- | The effects necessary for concrete interpretation.
|
||||
-- --
|
||||
-- -- NOTE: Uses a lazy, non-memoized linker strategy where Effects are stored in the linker and run each time they are needed.
|
||||
-- type Evaluating v
|
||||
-- = '[ Fail
|
||||
-- , State (Store (LocationFor v) v)
|
||||
-- , State (EnvironmentFor v) -- Global (imperative) environment
|
||||
-- , Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
|
||||
-- , Reader (Linker (Evaluator v))
|
||||
-- ]
|
||||
--
|
||||
-- newtype Evaluator v = Evaluator { runEvaluator :: Eff (Evaluating v) v }
|
||||
--
|
||||
-- -- | Require/import another file and return an Effect.
|
||||
-- require :: forall v term es.
|
||||
-- ( Members (Evaluating v) es
|
||||
-- , FreeVariables term
|
||||
-- )
|
||||
-- => term -> Eff es v
|
||||
-- require term = do
|
||||
-- let [name'] = toList (freeVariables term)
|
||||
-- let name = BC.unpack name'
|
||||
-- linker <- ask @(Linker (Evaluator v))
|
||||
-- maybe (fail ("cannot find " <> show name)) (raiseEmbedded . runEvaluator) (linkerLookup name linker)
|
||||
--
|
||||
-- -- | Evaluate a term to a value.
|
||||
-- evaluate :: forall v term.
|
||||
-- ( Ord v
|
||||
-- , Ord (LocationFor v)
|
||||
-- , Evaluatable (Evaluating v) term v (Base term)
|
||||
-- , Recursive term
|
||||
-- )
|
||||
-- => term
|
||||
-- -> Final (Evaluating v) v
|
||||
-- evaluate = run @(Evaluating v) . fix (const step)
|
||||
--
|
||||
-- -- | Evaluate terms and an entry point to a value.
|
||||
-- evaluates :: forall v term.
|
||||
-- ( Ord v
|
||||
-- , Ord (LocationFor v)
|
||||
-- , Evaluatable (Evaluating v) term v (Base term)
|
||||
-- , Recursive term
|
||||
-- )
|
||||
-- => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
|
||||
-- -> (Blob, term) -- Entrypoint
|
||||
-- -> Final (Evaluating v) v
|
||||
-- evaluates pairs = run @(Evaluating v) . fix go
|
||||
-- where
|
||||
-- go _ (Blob{..}, t) = local (const (Linker (Map.fromList (map toPathActionPair pairs)))) (step @v t)
|
||||
-- toPathActionPair (Blob{..}, t) = (dropExtensions blobPath, Evaluator (step @v t))
|
||||
|
||||
|
||||
|
||||
-- | The effects necessary for concrete interpretation.
|
||||
--
|
||||
-- NOTE: Uses a memoizing linker strategy.
|
||||
type Evaluating t v
|
||||
type Evaluating v
|
||||
= '[ Fail
|
||||
, State (Store (LocationFor v) v)
|
||||
, State (EnvironmentFor v) -- Global (imperative) environment
|
||||
, Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
|
||||
, State (Linker t v)
|
||||
, Reader (Linker (Evaluator v))
|
||||
, State (Linker v)
|
||||
]
|
||||
|
||||
-- | Require/import another file and return an Effect.
|
||||
newtype Evaluator v = Evaluator { runEvaluator :: Eff (Evaluating v) v }
|
||||
|
||||
-- | Require/import another term/file and return an Effect.
|
||||
--
|
||||
-- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module.
|
||||
require :: forall v term es.
|
||||
( Member Fail es
|
||||
, Member (State (Linker term v)) es
|
||||
, Evaluatable es term v (Base term)
|
||||
, Recursive term
|
||||
, FreeVariables term)
|
||||
( Members (Evaluating v) es
|
||||
, FreeVariables term
|
||||
)
|
||||
=> term -> Eff es v
|
||||
require term = do
|
||||
let [name'] = toList (freeVariables term)
|
||||
let name = BC.unpack name'
|
||||
linker <- get @(Linker term v)
|
||||
maybe (evalModule linker name) (trace ("require:" <> name) pure) (linkerLookupValue name linker)
|
||||
where
|
||||
evalModule linker name = case linkerLookupTerm name linker of
|
||||
Just m -> do
|
||||
v <- step @v m
|
||||
modify @(Linker term v) (linkerInsert name v)
|
||||
trace ("require[eval]:" <> name) (pure v)
|
||||
_ -> fail ("cannot find " <> show name)
|
||||
require term = get @(Linker v) >>= maybe (load term) pure . linkerLookup name
|
||||
where name = moduleName term
|
||||
|
||||
-- | Load another term/file and return an Effect.
|
||||
--
|
||||
-- Always loads/evaluates.
|
||||
load :: forall v term es.
|
||||
( Members (Evaluating v) es
|
||||
, FreeVariables term
|
||||
)
|
||||
=> term -> Eff es v
|
||||
load term = ask @(Linker (Evaluator v)) >>= maybe (fail ("cannot find " <> show name)) evalAndCache . linkerLookup name
|
||||
where name = moduleName term
|
||||
evalAndCache e = do
|
||||
v <- raiseEmbedded (runEvaluator e)
|
||||
modify @(Linker v) (linkerInsert name v)
|
||||
pure v
|
||||
|
||||
-- | Get a module name from a term (expects single free variables).
|
||||
moduleName :: FreeVariables term => term -> Prelude.String
|
||||
moduleName term = let [n] = toList (freeVariables term) in BC.unpack n
|
||||
|
||||
|
||||
-- | Evaluate a term to a value.
|
||||
evaluate :: forall v term.
|
||||
( Ord v
|
||||
, Ord (LocationFor v)
|
||||
, Evaluatable (Evaluating term v) term v (Base term)
|
||||
, Evaluatable (Evaluating v) term v (Base term)
|
||||
, Recursive term
|
||||
)
|
||||
=> term
|
||||
-> Final (Evaluating term v) v
|
||||
evaluate = run @(Evaluating term v) . fix (const step)
|
||||
-> Final (Evaluating v) v
|
||||
evaluate = run @(Evaluating v) . fix (const step)
|
||||
|
||||
-- | Evaluate terms and an entry point to a value.
|
||||
evaluates :: forall v term.
|
||||
( Ord v
|
||||
, Ord (LocationFor v)
|
||||
, Evaluatable (Evaluating term v) term v (Base term)
|
||||
, Evaluatable (Evaluating v) term v (Base term)
|
||||
, Recursive term
|
||||
)
|
||||
=> [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
|
||||
-> (Blob, term) -- Entrypoint
|
||||
-> Final (Evaluating term v) v
|
||||
evaluates pairs = run @(Evaluating term v) . fix go
|
||||
-> Final (Evaluating v) v
|
||||
evaluates pairs = run @(Evaluating v) . fix go
|
||||
where
|
||||
go _ (Blob{..}, t) = do
|
||||
put (Linker @term @v Map.empty (Map.fromList (fmap toPathActionPair pairs)))
|
||||
trace ("step[entryPoint]: " <> show blobPath) (step @v t)
|
||||
toPathActionPair (Blob{..}, t) = (dropExtensions blobPath, t)
|
||||
|
||||
|
||||
-- | The effects necessary for concrete interpretation.
|
||||
--
|
||||
-- NOTE: Uses a preload linker strategy.
|
||||
type Evaluating' v
|
||||
= '[ Fail
|
||||
, State (Store (LocationFor v) v)
|
||||
, State (EnvironmentFor v) -- Global (imperative) environment
|
||||
, Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
|
||||
, Reader (Linker' v)
|
||||
]
|
||||
|
||||
-- | Require/import another file and return an Effect.
|
||||
require' :: forall v term es.
|
||||
( Member Fail es
|
||||
, Member (Reader (Linker' v)) es
|
||||
, FreeVariables term
|
||||
)
|
||||
=> term -> Eff es v
|
||||
require' term = do
|
||||
let [name'] = toList (freeVariables term)
|
||||
let name = BC.unpack name'
|
||||
linker <- ask
|
||||
maybe (fail ("cannot find " <> show name)) pure (linkerLookup name linker)
|
||||
|
||||
-- | Evaluate a term to a value.
|
||||
evaluate' :: forall v term.
|
||||
( Ord v
|
||||
, Ord (LocationFor v)
|
||||
, Evaluatable (Evaluating' v) term v (Base term)
|
||||
, Recursive term
|
||||
)
|
||||
=> term
|
||||
-> Final (Evaluating' v) v
|
||||
evaluate' = run @(Evaluating' v) . fix (const step)
|
||||
|
||||
-- | Evaluate terms and an entry point to a value.
|
||||
evaluates' :: forall v term.
|
||||
( Ord v
|
||||
, Ord (LocationFor v)
|
||||
, Evaluatable (Evaluating' v) term v (Base term)
|
||||
, Recursive term
|
||||
)
|
||||
=> [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
|
||||
-> (Blob, term) -- Entrypoint
|
||||
-> Final (Evaluating' v) v
|
||||
evaluates' pairs = run @(Evaluating' v) . fix go
|
||||
where
|
||||
go _ (Blob{..}, t) = do
|
||||
modules <- for pairs $ \(Blob{..}, t) -> do
|
||||
v <- trace ("step: " <> show blobPath) $ step @v t
|
||||
pure (dropExtensions blobPath, v)
|
||||
local (const (Linker' (Map.fromList modules))) (trace ("step: " <> show blobPath) (step @v t))
|
||||
|
||||
|
||||
-- | The effects necessary for concrete interpretation.
|
||||
--
|
||||
-- NOTE: Uses a lazy, non-memoized linker strategy where Effects are stored in the linker and run each time they are needed.
|
||||
type Evaluating'' v
|
||||
= '[ Fail
|
||||
, State (Store (LocationFor v) v)
|
||||
, State (EnvironmentFor v) -- Global (imperative) environment
|
||||
, Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
|
||||
, Reader (Linker' (Evaluator v))
|
||||
]
|
||||
|
||||
newtype Evaluator v = Evaluator { runEvaluator :: Eff (Evaluating'' v) v }
|
||||
|
||||
-- | Require/import another file and return an Effect.
|
||||
require'' :: forall v term es.
|
||||
( Members (Evaluating'' v) es
|
||||
, FreeVariables term
|
||||
)
|
||||
=> term -> Eff es v
|
||||
require'' term = do
|
||||
let [name'] = toList (freeVariables term)
|
||||
let name = BC.unpack name'
|
||||
linker <- trace ("require: " <> show name) $ ask @(Linker' (Evaluator v))
|
||||
maybe (fail ("cannot find " <> show name)) (raiseEmbedded . runEvaluator) (linkerLookup name linker)
|
||||
|
||||
-- | Evaluate a term to a value.
|
||||
evaluate'' :: forall v term.
|
||||
( Ord v
|
||||
, Ord (LocationFor v)
|
||||
, Evaluatable (Evaluating'' v) term v (Base term)
|
||||
, Recursive term
|
||||
)
|
||||
=> term
|
||||
-> Final (Evaluating'' v) v
|
||||
evaluate'' = run @(Evaluating'' v) . fix (const step)
|
||||
|
||||
-- | Evaluate terms and an entry point to a value.
|
||||
evaluates'' :: forall v term.
|
||||
( Ord v
|
||||
, Ord (LocationFor v)
|
||||
, Evaluatable (Evaluating'' v) term v (Base term)
|
||||
, Recursive term
|
||||
)
|
||||
=> [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated
|
||||
-> (Blob, term) -- Entrypoint
|
||||
-> Final (Evaluating'' v) v
|
||||
evaluates'' pairs = run @(Evaluating'' v) . fix go
|
||||
where
|
||||
go _ (Blob{..}, t) = local (const (Linker' (Map.fromList (map toPathActionPair pairs)))) (trace ("step: " <> show blobPath) (step @v t))
|
||||
go _ (Blob{..}, t) = local (const (Linker (Map.fromList (map toPathActionPair pairs)))) (step @v t)
|
||||
toPathActionPair (Blob{..}, t) = (dropExtensions blobPath, Evaluator (step @v t))
|
||||
|
||||
|
||||
-- | The effects necessary for concrete interpretation.
|
||||
--
|
||||
-- NOTE: Allows for both the concepts of requiring and loading.
|
||||
-- * require - evaluates the specified term and memoizes the resulting value (and environment), future calls to require the same file do not re-evaluate.
|
||||
-- * load - always evaluates the specified term.
|
||||
type Evaluating''' v
|
||||
= '[ Fail
|
||||
, State (Store (LocationFor v) v)
|
||||
, State (EnvironmentFor v) -- Global (imperative) environment
|
||||
, Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure)
|
||||
, State (Module (Evaluator' v) v)
|
||||
]
|
||||
|
||||
newtype Evaluator' v = Evaluator' { unEvaluator' :: Eff (Evaluating''' v) v }
|
||||
|
||||
-- | Load another file and return an Effect.
|
||||
load :: forall v term es.
|
||||
( Members (Evaluating''' v) es
|
||||
, FreeVariables term
|
||||
)
|
||||
=> term -> Eff es v
|
||||
load term = do
|
||||
let name = moduleName term
|
||||
module' <- get @(Module (Evaluator' v) v)
|
||||
maybe (fail ("cannot find " <> show name)) (raiseEmbedded . unEvaluator' . Prelude.fst) (moduleLookup name module')
|
||||
|
||||
-- | Require/import another file and return an Effect.
|
||||
require''' :: forall v term es.
|
||||
( Members (Evaluating''' v) es
|
||||
, FreeVariables term
|
||||
)
|
||||
=> term -> Eff es v
|
||||
require''' term = do
|
||||
let name = moduleName term
|
||||
module' <- get @(Module (Evaluator' v) v)
|
||||
case moduleLookup name module' of
|
||||
Just (m, Nothing) -> do
|
||||
v <- raiseEmbedded (unEvaluator' m)
|
||||
modify @(Module (Evaluator' v) v) (moduleInsert name v)
|
||||
pure v
|
||||
Just (_, Just v) -> pure v
|
||||
_ -> fail ("cannot find " <> show name)
|
||||
|
||||
moduleName :: FreeVariables term => term -> Prelude.String
|
||||
moduleName term = let [name'] = toList (freeVariables term) in BC.unpack name'
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module Data.Abstract.Linker where
|
||||
|
||||
import Data.Semigroup
|
||||
@ -6,34 +6,11 @@ import GHC.Generics
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
newtype Module e v = Module { unModule :: Map.Map FilePath (e, Maybe v) }
|
||||
|
||||
moduleLookup :: FilePath -> Module e v -> Maybe (e, Maybe v)
|
||||
moduleLookup k = Map.lookup k . unModule
|
||||
|
||||
moduleInsert :: FilePath -> v -> Module e v -> Module e v
|
||||
moduleInsert k v Module{..} = Module $ Map.update (\(x, _) -> Just (x, Just v)) k unModule
|
||||
|
||||
|
||||
data Linker t a = Linker { linkerValues :: Map.Map FilePath a, linkerTerms :: Map.Map FilePath t }
|
||||
deriving (Eq, Foldable, Functor, Generic1, Ord, Semigroup, Show, Traversable)
|
||||
|
||||
instance Monoid (Linker t a) where
|
||||
mempty = Linker Map.empty Map.empty
|
||||
mappend (Linker v1 t1) (Linker v2 t2) = Linker (Map.union v1 v2) (Map.union t1 t2)
|
||||
|
||||
linkerLookupValue :: FilePath -> Linker t a -> Maybe a
|
||||
linkerLookupValue k = Map.lookup k . linkerValues
|
||||
|
||||
linkerLookupTerm :: FilePath -> Linker t a -> Maybe t
|
||||
linkerLookupTerm k = Map.lookup k . linkerTerms
|
||||
|
||||
linkerInsert :: FilePath -> a -> Linker t a -> Linker t a
|
||||
linkerInsert k v Linker{..} = Linker (Map.insert k v linkerValues) (Map.delete k linkerTerms)
|
||||
|
||||
|
||||
newtype Linker' a = Linker' { unLinker :: Map.Map FilePath a }
|
||||
newtype Linker a = Linker { unLinker :: Map.Map FilePath a }
|
||||
deriving (Eq, Foldable, Functor, Generic1, Monoid, Ord, Semigroup, Show, Traversable)
|
||||
|
||||
linkerLookup :: FilePath -> Linker' a -> Maybe a
|
||||
linkerLookup :: FilePath -> Linker a -> Maybe a
|
||||
linkerLookup k = Map.lookup k . unLinker
|
||||
|
||||
linkerInsert :: FilePath -> a -> Linker a -> Linker a
|
||||
linkerInsert k v Linker{..} = Linker (Map.insert k v unLinker)
|
||||
|
||||
@ -280,7 +280,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance ( Show l
|
||||
, Show t
|
||||
, Members (Evaluating t (Value l t)) es
|
||||
, Members (Evaluating (Value l t)) es
|
||||
, Evaluatable es t (Value l t) (Base t)
|
||||
, Recursive t
|
||||
, FreeVariables t
|
||||
|
||||
Loading…
Reference in New Issue
Block a user