mirror of
https://github.com/github/semantic.git
synced 2024-12-25 16:02:43 +03:00
Merge branch 'master' into haskell-assignment
This commit is contained in:
commit
b270130cc0
@ -42,8 +42,8 @@ library
|
|||||||
, Control.Abstract.Environment
|
, Control.Abstract.Environment
|
||||||
, Control.Abstract.Evaluator
|
, Control.Abstract.Evaluator
|
||||||
, Control.Abstract.Exports
|
, Control.Abstract.Exports
|
||||||
, Control.Abstract.Goto
|
|
||||||
, Control.Abstract.Heap
|
, Control.Abstract.Heap
|
||||||
|
, Control.Abstract.Hole
|
||||||
, Control.Abstract.Matching
|
, Control.Abstract.Matching
|
||||||
, Control.Abstract.Modules
|
, Control.Abstract.Modules
|
||||||
, Control.Abstract.Primitive
|
, Control.Abstract.Primitive
|
||||||
@ -72,7 +72,6 @@ library
|
|||||||
, Data.Abstract.Value
|
, Data.Abstract.Value
|
||||||
-- General datatype definitions & generic algorithms
|
-- General datatype definitions & generic algorithms
|
||||||
, Data.Algebra
|
, Data.Algebra
|
||||||
, Data.Align.Generic
|
|
||||||
, Data.AST
|
, Data.AST
|
||||||
, Data.Blob
|
, Data.Blob
|
||||||
, Data.Diff
|
, Data.Diff
|
||||||
@ -270,7 +269,6 @@ test-suite test
|
|||||||
, Data.Abstract.Path.Spec
|
, Data.Abstract.Path.Spec
|
||||||
, Data.Functor.Classes.Generic.Spec
|
, Data.Functor.Classes.Generic.Spec
|
||||||
, Data.Functor.Listable
|
, Data.Functor.Listable
|
||||||
, Data.Mergeable.Spec
|
|
||||||
, Data.Scientific.Spec
|
, Data.Scientific.Spec
|
||||||
, Data.Source.Spec
|
, Data.Source.Spec
|
||||||
, Data.Term.Spec
|
, Data.Term.Spec
|
||||||
|
@ -13,62 +13,60 @@ import Data.Semilattice.Lower
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | Look up the set of values for a given configuration in the in-cache.
|
-- | Look up the set of values for a given configuration in the in-cache.
|
||||||
consultOracle :: (Cacheable term location (Cell location) value, Member (Reader (Cache term location (Cell location) value)) effects)
|
consultOracle :: (Cacheable term address (Cell address) value, Member (Reader (Cache term address (Cell address) value)) effects)
|
||||||
=> Configuration term location (Cell location) value
|
=> Configuration term address (Cell address) value
|
||||||
-> TermEvaluator term location value effects (Set (Cached location (Cell location) value))
|
-> TermEvaluator term address value effects (Set (Cached address (Cell address) value))
|
||||||
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
|
consultOracle configuration = fromMaybe mempty . cacheLookup configuration <$> ask
|
||||||
|
|
||||||
-- | Run an action with the given in-cache.
|
-- | Run an action with the given in-cache.
|
||||||
withOracle :: Member (Reader (Cache term location (Cell location) value)) effects
|
withOracle :: Member (Reader (Cache term address (Cell address) value)) effects
|
||||||
=> Cache term location (Cell location) value
|
=> Cache term address (Cell address) value
|
||||||
-> TermEvaluator term location value effects a
|
-> TermEvaluator term address value effects a
|
||||||
-> TermEvaluator term location value effects a
|
-> TermEvaluator term address value effects a
|
||||||
withOracle cache = local (const cache)
|
withOracle cache = local (const cache)
|
||||||
|
|
||||||
|
|
||||||
-- | Look up the set of values for a given configuration in the out-cache.
|
-- | Look up the set of values for a given configuration in the out-cache.
|
||||||
lookupCache :: (Cacheable term location (Cell location) value, Member (State (Cache term location (Cell location) value)) effects)
|
lookupCache :: (Cacheable term address (Cell address) value, Member (State (Cache term address (Cell address) value)) effects)
|
||||||
=> Configuration term location (Cell location) value
|
=> Configuration term address (Cell address) value
|
||||||
-> TermEvaluator term location value effects (Maybe (Set (Cached location (Cell location) value)))
|
-> TermEvaluator term address value effects (Maybe (Set (Cached address (Cell address) value)))
|
||||||
lookupCache configuration = cacheLookup configuration <$> get
|
lookupCache configuration = cacheLookup configuration <$> get
|
||||||
|
|
||||||
-- | Run an action, caching its result and 'Heap' under the given configuration.
|
-- | Run an action, caching its result and 'Heap' under the given configuration.
|
||||||
cachingConfiguration :: (Cacheable term location (Cell location) value, Members '[State (Cache term location (Cell location) value), State (Heap location (Cell location) value)] effects)
|
cachingConfiguration :: (Cacheable term address (Cell address) value, Member (State (Cache term address (Cell address) value)) effects, Member (State (Heap address (Cell address) value)) effects)
|
||||||
=> Configuration term location (Cell location) value
|
=> Configuration term address (Cell address) value
|
||||||
-> Set (Cached location (Cell location) value)
|
-> Set (Cached address (Cell address) value)
|
||||||
-> TermEvaluator term location value effects (ValueRef value)
|
-> TermEvaluator term address value effects (ValueRef value)
|
||||||
-> TermEvaluator term location value effects (ValueRef value)
|
-> TermEvaluator term address value effects (ValueRef value)
|
||||||
cachingConfiguration configuration values action = do
|
cachingConfiguration configuration values action = do
|
||||||
modify' (cacheSet configuration values)
|
modify' (cacheSet configuration values)
|
||||||
result <- Cached <$> action <*> TermEvaluator getHeap
|
result <- Cached <$> action <*> TermEvaluator getHeap
|
||||||
cachedValue result <$ modify' (cacheInsert configuration result)
|
cachedValue result <$ modify' (cacheInsert configuration result)
|
||||||
|
|
||||||
putCache :: Member (State (Cache term location (Cell location) value)) effects
|
putCache :: Member (State (Cache term address (Cell address) value)) effects
|
||||||
=> Cache term location (Cell location) value
|
=> Cache term address (Cell address) value
|
||||||
-> TermEvaluator term location value effects ()
|
-> TermEvaluator term address value effects ()
|
||||||
putCache = put
|
putCache = put
|
||||||
|
|
||||||
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
|
-- | Run an action starting from an empty out-cache, and return the out-cache afterwards.
|
||||||
isolateCache :: Member (State (Cache term location (Cell location) value)) effects
|
isolateCache :: Member (State (Cache term address (Cell address) value)) effects
|
||||||
=> TermEvaluator term location value effects a
|
=> TermEvaluator term address value effects a
|
||||||
-> TermEvaluator term location value effects (Cache term location (Cell location) value)
|
-> TermEvaluator term address value effects (Cache term address (Cell address) value)
|
||||||
isolateCache action = putCache lowerBound *> action *> get
|
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.
|
-- | Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache.
|
||||||
cachingTerms :: ( Cacheable term location (Cell location) value
|
cachingTerms :: ( Cacheable term address (Cell address) value
|
||||||
, Corecursive term
|
, Corecursive term
|
||||||
, Members '[ Fresh
|
, Member NonDet effects
|
||||||
, NonDet
|
, Member (Reader (Cache term address (Cell address) value)) effects
|
||||||
, Reader (Cache term location (Cell location) value)
|
, Member (Reader (Live address)) effects
|
||||||
, Reader (Live location value)
|
, Member (State (Cache term address (Cell address) value)) effects
|
||||||
, State (Cache term location (Cell location) value)
|
, Member (State (Environment address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
, State (Heap location (Cell location) value)
|
|
||||||
] effects
|
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects (ValueRef value))
|
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value))
|
||||||
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects (ValueRef value))
|
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects (ValueRef value))
|
||||||
cachingTerms recur term = do
|
cachingTerms recur term = do
|
||||||
c <- getConfiguration (embedSubterm term)
|
c <- getConfiguration (embedSubterm term)
|
||||||
cached <- lookupCache c
|
cached <- lookupCache c
|
||||||
@ -78,23 +76,21 @@ cachingTerms recur term = do
|
|||||||
pairs <- consultOracle c
|
pairs <- consultOracle c
|
||||||
cachingConfiguration c pairs (recur term)
|
cachingConfiguration c pairs (recur term)
|
||||||
|
|
||||||
convergingModules :: ( AbstractValue location value effects
|
convergingModules :: ( AbstractValue address value effects
|
||||||
, Cacheable term location (Cell location) value
|
, Cacheable term address (Cell address) value
|
||||||
, Members '[ Allocator location value
|
, Member (Allocator address value) effects
|
||||||
, Fresh
|
, Member Fresh effects
|
||||||
, NonDet
|
, Member NonDet effects
|
||||||
, Reader (Cache term location (Cell location) value)
|
, Member (Reader (Cache term address (Cell address) value)) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, Reader (Live location value)
|
, Member (Reader (Live address)) effects
|
||||||
, Resumable (AddressError location value)
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, Resumable (EnvironmentError value)
|
, Member (State (Cache term address (Cell address) value)) effects
|
||||||
, State (Cache term location (Cell location) value)
|
, Member (State (Environment address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
, State (Heap location (Cell location) value)
|
|
||||||
] effects
|
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra Module term (TermEvaluator term location value effects value)
|
=> SubtermAlgebra Module term (TermEvaluator term address value effects value)
|
||||||
-> SubtermAlgebra Module term (TermEvaluator term location value effects value)
|
-> SubtermAlgebra Module term (TermEvaluator term address value effects value)
|
||||||
convergingModules recur m = do
|
convergingModules recur m = do
|
||||||
c <- getConfiguration (subterm (moduleBody m))
|
c <- getConfiguration (subterm (moduleBody m))
|
||||||
-- Convergence here is predicated upon an Eq instance, not α-equivalence
|
-- Convergence here is predicated upon an Eq instance, not α-equivalence
|
||||||
@ -128,11 +124,11 @@ converge seed f = loop seed
|
|||||||
loop x'
|
loop x'
|
||||||
|
|
||||||
-- | Nondeterministically write each of a collection of stores & return their associated results.
|
-- | Nondeterministically write each of a collection of stores & return their associated results.
|
||||||
scatter :: (Foldable t, Members '[NonDet, State (Heap location (Cell location) value)] effects) => t (Cached location (Cell location) value) -> TermEvaluator term location value effects (ValueRef value)
|
scatter :: (Foldable t, Member NonDet effects, Member (State (Heap address (Cell address) value)) effects) => t (Cached address (Cell address) value) -> TermEvaluator term address value effects (ValueRef value)
|
||||||
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)
|
scatter = foldMapA (\ (Cached value heap') -> TermEvaluator (putHeap heap') $> value)
|
||||||
|
|
||||||
|
|
||||||
caching :: Alternative f => TermEvaluator term location value (NonDet ': Reader (Cache term location (Cell location) value) ': State (Cache term location (Cell location) value) ': effects) a -> TermEvaluator term location value effects (f a, Cache term location (Cell location) value)
|
caching :: Alternative f => TermEvaluator term address value (NonDet ': Reader (Cache term address (Cell address) value) ': State (Cache term address (Cell address) value) ': effects) a -> TermEvaluator term address value effects (f a, Cache term address (Cell address) value)
|
||||||
caching
|
caching
|
||||||
= runState lowerBound
|
= runState lowerBound
|
||||||
. runReader lowerBound
|
. runReader lowerBound
|
||||||
|
@ -11,38 +11,37 @@ import Data.Semilattice.Lower
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | An analysis performing GC after every instruction.
|
-- | An analysis performing GC after every instruction.
|
||||||
collectingTerms :: ( Foldable (Cell location)
|
collectingTerms :: ( Foldable (Cell address)
|
||||||
, Members '[ Reader (Live location value)
|
, Member (Reader (Live address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
] effects
|
, Ord address
|
||||||
, Ord location
|
, ValueRoots address value
|
||||||
, ValueRoots location value
|
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects value)
|
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects value)
|
||||||
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects value)
|
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects value)
|
||||||
collectingTerms recur term = do
|
collectingTerms recur term = do
|
||||||
roots <- TermEvaluator askRoots
|
roots <- TermEvaluator askRoots
|
||||||
v <- recur term
|
v <- recur term
|
||||||
v <$ TermEvaluator (modifyHeap (gc (roots <> valueRoots v)))
|
v <$ TermEvaluator (modifyHeap (gc (roots <> valueRoots v)))
|
||||||
|
|
||||||
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
|
-- | Collect any addresses in the heap not rooted in or reachable from the given 'Live' set.
|
||||||
gc :: ( Ord location
|
gc :: ( Ord address
|
||||||
, Foldable (Cell location)
|
, Foldable (Cell address)
|
||||||
, ValueRoots location value
|
, ValueRoots address value
|
||||||
)
|
)
|
||||||
=> Live location value -- ^ The set of addresses to consider rooted.
|
=> Live address -- ^ The set of addresses to consider rooted.
|
||||||
-> Heap location (Cell location) value -- ^ A heap to collect unreachable addresses within.
|
-> Heap address (Cell address) value -- ^ A heap to collect unreachable addresses within.
|
||||||
-> Heap location (Cell location) value -- ^ A garbage-collected heap.
|
-> Heap address (Cell address) value -- ^ A garbage-collected heap.
|
||||||
gc roots heap = heapRestrict heap (reachable roots heap)
|
gc roots heap = heapRestrict heap (reachable roots heap)
|
||||||
|
|
||||||
-- | Compute the set of addresses reachable from a given root set in a given heap.
|
-- | Compute the set of addresses reachable from a given root set in a given heap.
|
||||||
reachable :: ( Ord location
|
reachable :: ( Ord address
|
||||||
, Foldable (Cell location)
|
, Foldable (Cell address)
|
||||||
, ValueRoots location value
|
, ValueRoots address value
|
||||||
)
|
)
|
||||||
=> Live location value -- ^ The set of root addresses.
|
=> Live address -- ^ The set of root addresses.
|
||||||
-> Heap location (Cell location) value -- ^ The heap to trace addresses through.
|
-> Heap address (Cell address) value -- ^ The heap to trace addresses through.
|
||||||
-> Live location value -- ^ The set of addresses reachable from the root set.
|
-> Live address -- ^ The set of addresses reachable from the root set.
|
||||||
reachable roots heap = go mempty roots
|
reachable roots heap = go mempty roots
|
||||||
where go seen set = case liveSplit set of
|
where go seen set = case liveSplit set of
|
||||||
Nothing -> seen
|
Nothing -> seen
|
||||||
@ -51,5 +50,5 @@ reachable roots heap = go mempty roots
|
|||||||
_ -> seen)
|
_ -> seen)
|
||||||
|
|
||||||
|
|
||||||
providingLiveSet :: Effectful (m location value) => m location value (Reader (Live location value) ': effects) a -> m location value effects a
|
providingLiveSet :: Effectful (m address value) => m address value (Reader (Live address) ': effects) a -> m address value effects a
|
||||||
providingLiveSet = runReader lowerBound
|
providingLiveSet = runReader lowerBound
|
||||||
|
@ -20,11 +20,11 @@ newtype Dead term = Dead { unDead :: Set term }
|
|||||||
deriving instance Ord term => Reducer term (Dead term)
|
deriving instance Ord term => Reducer term (Dead term)
|
||||||
|
|
||||||
-- | Update the current 'Dead' set.
|
-- | Update the current 'Dead' set.
|
||||||
killAll :: Member (State (Dead term)) effects => Dead term -> TermEvaluator term location value effects ()
|
killAll :: Member (State (Dead term)) effects => Dead term -> TermEvaluator term address value effects ()
|
||||||
killAll = put
|
killAll = put
|
||||||
|
|
||||||
-- | Revive a single term, removing it from the current 'Dead' set.
|
-- | Revive a single term, removing it from the current 'Dead' set.
|
||||||
revive :: (Member (State (Dead term)) effects, Ord term) => term -> TermEvaluator term location value effects ()
|
revive :: (Member (State (Dead term)) effects, Ord term) => term -> TermEvaluator term address value effects ()
|
||||||
revive t = modify' (Dead . delete t . unDead)
|
revive t = modify' (Dead . delete t . unDead)
|
||||||
|
|
||||||
-- | Compute the set of all subterms recursively.
|
-- | Compute the set of all subterms recursively.
|
||||||
@ -36,8 +36,8 @@ revivingTerms :: ( Corecursive term
|
|||||||
, Member (State (Dead term)) effects
|
, Member (State (Dead term)) effects
|
||||||
, Ord term
|
, Ord term
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
|
=> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
|
||||||
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
|
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
|
||||||
revivingTerms recur term = revive (embedSubterm term) *> recur term
|
revivingTerms recur term = revive (embedSubterm term) *> recur term
|
||||||
|
|
||||||
killingModules :: ( Foldable (Base term)
|
killingModules :: ( Foldable (Base term)
|
||||||
@ -45,9 +45,9 @@ killingModules :: ( Foldable (Base term)
|
|||||||
, Ord term
|
, Ord term
|
||||||
, Recursive term
|
, Recursive term
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra Module term (TermEvaluator term location value effects a)
|
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
|
||||||
-> SubtermAlgebra Module term (TermEvaluator term location value effects a)
|
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
|
||||||
killingModules recur m = killAll (subterms (subterm (moduleBody m))) *> recur m
|
killingModules recur m = killAll (subterms (subterm (moduleBody m))) *> recur m
|
||||||
|
|
||||||
providingDeadSet :: TermEvaluator term location value (State (Dead term) ': effects) a -> TermEvaluator term location value effects (a, Dead term)
|
providingDeadSet :: TermEvaluator term address value (State (Dead term) ': effects) a -> TermEvaluator term address value effects (a, Dead term)
|
||||||
providingDeadSet = runState lowerBound
|
providingDeadSet = runState lowerBound
|
||||||
|
@ -8,34 +8,34 @@ import Control.Abstract
|
|||||||
import Data.Semilattice.Lower
|
import Data.Semilattice.Lower
|
||||||
|
|
||||||
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
|
-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@.
|
||||||
data EvaluatingState location value = EvaluatingState
|
data EvaluatingState address value = EvaluatingState
|
||||||
{ environment :: Environment location
|
{ environment :: Environment address
|
||||||
, heap :: Heap location (Cell location) value
|
, heap :: Heap address (Cell address) value
|
||||||
, modules :: ModuleTable (Maybe (Environment location, value))
|
, modules :: ModuleTable (Maybe (Environment address, value))
|
||||||
, exports :: Exports location
|
, exports :: Exports address
|
||||||
}
|
}
|
||||||
|
|
||||||
deriving instance (Eq (Cell location value), Eq location, Eq value) => Eq (EvaluatingState location value)
|
deriving instance (Eq (Cell address value), Eq address, Eq value) => Eq (EvaluatingState address value)
|
||||||
deriving instance (Ord (Cell location value), Ord location, Ord value) => Ord (EvaluatingState location value)
|
deriving instance (Ord (Cell address value), Ord address, Ord value) => Ord (EvaluatingState address value)
|
||||||
deriving instance (Show (Cell location value), Show location, Show value) => Show (EvaluatingState location value)
|
deriving instance (Show (Cell address value), Show address, Show value) => Show (EvaluatingState address value)
|
||||||
|
|
||||||
|
|
||||||
evaluating :: Evaluator location value
|
evaluating :: Evaluator address value
|
||||||
( Fail
|
( Fail
|
||||||
': Fresh
|
': Fresh
|
||||||
': Reader (Environment location)
|
': Reader (Environment address)
|
||||||
': State (Environment location)
|
': State (Environment address)
|
||||||
': State (Heap location (Cell location) value)
|
': State (Heap address (Cell address) value)
|
||||||
': State (ModuleTable (Maybe (Environment location, value)))
|
': State (ModuleTable (Maybe (Environment address, value)))
|
||||||
': State (Exports location)
|
': State (Exports address)
|
||||||
': effects) result
|
': effects) result
|
||||||
-> Evaluator location value effects (Either String result, EvaluatingState location value)
|
-> Evaluator address value effects (Either String result, EvaluatingState address value)
|
||||||
evaluating
|
evaluating
|
||||||
= fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports))
|
= fmap (\ ((((result, env), heap), modules), exports) -> (result, EvaluatingState env heap modules exports))
|
||||||
. runState lowerBound -- State (Exports location)
|
. runState lowerBound -- State (Exports address)
|
||||||
. runState lowerBound -- State (ModuleTable (Maybe (Environment location, value)))
|
. runState lowerBound -- State (ModuleTable (Maybe (Environment address, value)))
|
||||||
. runState lowerBound -- State (Heap location (Cell location) value)
|
. runState lowerBound -- State (Heap address (Cell address) value)
|
||||||
. runState lowerBound -- State (Environment location)
|
. runState lowerBound -- State (Environment address)
|
||||||
. runReader lowerBound -- Reader (Environment location)
|
. runReader lowerBound -- Reader (Environment address)
|
||||||
. runFresh 0
|
. runFresh 0
|
||||||
. runFail
|
. runFail
|
||||||
|
@ -52,15 +52,14 @@ style = (defaultStyle (byteString . vertexName))
|
|||||||
|
|
||||||
-- | Add vertices to the graph for evaluated identifiers.
|
-- | Add vertices to the graph for evaluated identifiers.
|
||||||
graphingTerms :: ( Element Syntax.Identifier syntax
|
graphingTerms :: ( Element Syntax.Identifier syntax
|
||||||
, Members '[ Reader (Environment (Located location))
|
, Member (Reader (Environment (Hole (Located address)))) effects
|
||||||
, Reader ModuleInfo
|
, Member (Reader ModuleInfo) effects
|
||||||
, State (Environment (Located location))
|
, Member (State (Environment (Hole (Located address)))) effects
|
||||||
, State (Graph Vertex)
|
, Member (State (Graph Vertex)) effects
|
||||||
] effects
|
|
||||||
, term ~ Term (Sum syntax) ann
|
, term ~ Term (Sum syntax) ann
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra (Base term) term (TermEvaluator term (Located location) value effects a)
|
=> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a)
|
||||||
-> SubtermAlgebra (Base term) term (TermEvaluator term (Located location) value effects a)
|
-> SubtermAlgebra (Base term) term (TermEvaluator term (Hole (Located address)) value effects a)
|
||||||
graphingTerms recur term@(In _ syntax) = do
|
graphingTerms recur term@(In _ syntax) = do
|
||||||
case project syntax of
|
case project syntax of
|
||||||
Just (Syntax.Identifier name) -> do
|
Just (Syntax.Identifier name) -> do
|
||||||
@ -69,23 +68,22 @@ graphingTerms recur term@(In _ syntax) = do
|
|||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
recur term
|
recur term
|
||||||
|
|
||||||
graphingPackages :: Members '[ Reader ModuleInfo
|
graphingPackages :: ( Member (Reader PackageInfo) effects
|
||||||
, Reader PackageInfo
|
, Member (State (Graph Vertex)) effects
|
||||||
, State (Graph Vertex)
|
)
|
||||||
] effects
|
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
|
||||||
=> SubtermAlgebra Module term (TermEvaluator term location value effects a)
|
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
|
||||||
-> SubtermAlgebra Module term (TermEvaluator term location value effects a)
|
|
||||||
graphingPackages recur m = packageInclusion (moduleVertex (moduleInfo m)) *> recur m
|
graphingPackages recur m = packageInclusion (moduleVertex (moduleInfo m)) *> recur m
|
||||||
|
|
||||||
-- | Add vertices to the graph for evaluated modules and the packages containing them.
|
-- | Add vertices to the graph for evaluated modules and the packages containing them.
|
||||||
graphingModules :: forall term location value effects a
|
graphingModules :: forall term address value effects a
|
||||||
. Members '[ Modules location value
|
. ( Member (Modules address value) effects
|
||||||
, Reader ModuleInfo
|
, Member (Reader ModuleInfo) effects
|
||||||
, State (Graph Vertex)
|
, Member (State (Graph Vertex)) effects
|
||||||
] effects
|
)
|
||||||
=> SubtermAlgebra Module term (TermEvaluator term location value effects a)
|
=> SubtermAlgebra Module term (TermEvaluator term address value effects a)
|
||||||
-> SubtermAlgebra Module term (TermEvaluator term location value effects a)
|
-> SubtermAlgebra Module term (TermEvaluator term address value effects a)
|
||||||
graphingModules recur m = interpose @(Modules location value) pure (\ m yield -> case m of
|
graphingModules recur m = interpose @(Modules address value) pure (\ m yield -> case m of
|
||||||
Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
|
Load path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
|
||||||
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
|
Lookup path -> moduleInclusion (moduleVertex (ModuleInfo path)) >> send m >>= yield
|
||||||
_ -> send m >>= yield)
|
_ -> send m >>= yield)
|
||||||
@ -100,9 +98,8 @@ moduleVertex = Module . BC.pack . modulePath
|
|||||||
|
|
||||||
-- | Add an edge from the current package to the passed vertex.
|
-- | Add an edge from the current package to the passed vertex.
|
||||||
packageInclusion :: ( Effectful m
|
packageInclusion :: ( Effectful m
|
||||||
, Members '[ Reader PackageInfo
|
, Member (Reader PackageInfo) effects
|
||||||
, State (Graph Vertex)
|
, Member (State (Graph Vertex)) effects
|
||||||
] effects
|
|
||||||
, Monad (m effects)
|
, Monad (m effects)
|
||||||
)
|
)
|
||||||
=> Vertex
|
=> Vertex
|
||||||
@ -113,9 +110,8 @@ packageInclusion v = do
|
|||||||
|
|
||||||
-- | Add an edge from the current module to the passed vertex.
|
-- | Add an edge from the current module to the passed vertex.
|
||||||
moduleInclusion :: ( Effectful m
|
moduleInclusion :: ( Effectful m
|
||||||
, Members '[ Reader ModuleInfo
|
, Member (Reader ModuleInfo) effects
|
||||||
, State (Graph Vertex)
|
, Member (State (Graph Vertex)) effects
|
||||||
] effects
|
|
||||||
, Monad (m effects)
|
, Monad (m effects)
|
||||||
)
|
)
|
||||||
=> Vertex
|
=> Vertex
|
||||||
@ -125,14 +121,14 @@ moduleInclusion v = do
|
|||||||
appendGraph (vertex (moduleVertex m) `connect` vertex v)
|
appendGraph (vertex (moduleVertex m) `connect` vertex v)
|
||||||
|
|
||||||
-- | Add an edge from the passed variable name to the module it originated within.
|
-- | Add an edge from the passed variable name to the module it originated within.
|
||||||
variableDefinition :: ( Member (Reader (Environment (Located location))) effects
|
variableDefinition :: ( Member (Reader (Environment (Hole (Located address)))) effects
|
||||||
, Member (State (Environment (Located location))) effects
|
, Member (State (Environment (Hole (Located address)))) effects
|
||||||
, Member (State (Graph Vertex)) effects
|
, Member (State (Graph Vertex)) effects
|
||||||
)
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> TermEvaluator term (Located location) value effects ()
|
-> TermEvaluator term (Hole (Located address)) value effects ()
|
||||||
variableDefinition name = do
|
variableDefinition name = do
|
||||||
graph <- maybe lowerBound (vertex . moduleVertex . locationModule . unAddress) <$> TermEvaluator (lookupEnv name)
|
graph <- maybe lowerBound (maybe lowerBound (vertex . moduleVertex . addressModule) . toMaybe) <$> TermEvaluator (lookupEnv name)
|
||||||
appendGraph (vertex (Variable (unName name)) `connect` graph)
|
appendGraph (vertex (Variable (unName name)) `connect` graph)
|
||||||
|
|
||||||
appendGraph :: (Effectful m, Member (State (Graph Vertex)) effects) => Graph Vertex -> m effects ()
|
appendGraph :: (Effectful m, Member (State (Graph Vertex)) effects) => Graph Vertex -> m effects ()
|
||||||
|
@ -13,20 +13,19 @@ import Prologue
|
|||||||
--
|
--
|
||||||
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
|
-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis.
|
||||||
tracingTerms :: ( Corecursive term
|
tracingTerms :: ( Corecursive term
|
||||||
, Members '[ Reader (Live location value)
|
, Member (Reader (Live address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
, Writer (trace (Configuration term location (Cell location) value))
|
, Member (Writer (trace (Configuration term address (Cell address) value))) effects
|
||||||
] effects
|
, Reducer (Configuration term address (Cell address) value) (trace (Configuration term address (Cell address) value))
|
||||||
, Reducer (Configuration term location (Cell location) value) (trace (Configuration term location (Cell location) value))
|
|
||||||
)
|
)
|
||||||
=> trace (Configuration term location (Cell location) value)
|
=> trace (Configuration term address (Cell address) value)
|
||||||
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
|
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
|
||||||
-> SubtermAlgebra (Base term) term (TermEvaluator term location value effects a)
|
-> SubtermAlgebra (Base term) term (TermEvaluator term address value effects a)
|
||||||
tracingTerms proxy recur term = getConfiguration (embedSubterm term) >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term
|
tracingTerms proxy recur term = getConfiguration (embedSubterm term) >>= trace . (`asTypeOf` proxy) . Reducer.unit >> recur term
|
||||||
|
|
||||||
trace :: Member (Writer (trace (Configuration term location (Cell location) value))) effects => trace (Configuration term location (Cell location) value) -> TermEvaluator term location value effects ()
|
trace :: Member (Writer (trace (Configuration term address (Cell address) value))) effects => trace (Configuration term address (Cell address) value) -> TermEvaluator term address value effects ()
|
||||||
trace = tell
|
trace = tell
|
||||||
|
|
||||||
tracing :: Monoid (trace (Configuration term location (Cell location) value)) => TermEvaluator term location value (Writer (trace (Configuration term location (Cell location) value)) ': effects) a -> TermEvaluator term location value effects (a, trace (Configuration term location (Cell location) value))
|
tracing :: Monoid (trace (Configuration term address (Cell address) value)) => TermEvaluator term address value (Writer (trace (Configuration term address (Cell address) value)) ': effects) a -> TermEvaluator term address value effects (a, trace (Configuration term address (Cell address) value))
|
||||||
tracing = runWriter
|
tracing = runWriter
|
||||||
|
@ -9,7 +9,7 @@ import Control.Abstract.Environment as X
|
|||||||
import Control.Abstract.Evaluator as X
|
import Control.Abstract.Evaluator as X
|
||||||
import Control.Abstract.Exports as X
|
import Control.Abstract.Exports as X
|
||||||
import Control.Abstract.Heap as X
|
import Control.Abstract.Heap as X
|
||||||
import Control.Abstract.Goto as X
|
import Control.Abstract.Hole as X
|
||||||
import Control.Abstract.Modules as X
|
import Control.Abstract.Modules as X
|
||||||
import Control.Abstract.Primitive as X
|
import Control.Abstract.Primitive as X
|
||||||
import Control.Abstract.Roots as X
|
import Control.Abstract.Roots as X
|
||||||
|
@ -5,39 +5,47 @@ module Control.Abstract.Addressable
|
|||||||
|
|
||||||
import Control.Abstract.Context
|
import Control.Abstract.Context
|
||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
|
import Control.Abstract.Hole
|
||||||
import Data.Abstract.Address
|
import Data.Abstract.Address
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | Defines allocation and dereferencing of 'Address'es in a 'Heap'.
|
-- | Defines allocation and dereferencing of addresses.
|
||||||
class (Ord location, Show location) => Addressable location effects where
|
class (Ord address, Show address) => Addressable address effects where
|
||||||
-- | The type into which stored values will be written for a given location type.
|
-- | The type into which stored values will be written for a given address type.
|
||||||
type family Cell location :: * -> *
|
type family Cell address :: * -> *
|
||||||
|
|
||||||
allocCell :: Name -> Evaluator location value effects location
|
allocCell :: Name -> Evaluator address value effects address
|
||||||
derefCell :: Address location value -> Cell location value -> Evaluator location value effects (Maybe value)
|
derefCell :: address -> Cell address value -> Evaluator address value effects (Maybe value)
|
||||||
|
|
||||||
|
|
||||||
-- | 'Precise' locations are always allocated a fresh 'Address', and dereference to the 'Latest' value written.
|
-- | 'Precise' addresses are always allocated a fresh address, and dereference to the 'Latest' value written.
|
||||||
instance Member Fresh effects => Addressable Precise effects where
|
instance Member Fresh effects => Addressable Precise effects where
|
||||||
type Cell Precise = Latest
|
type Cell Precise = Latest
|
||||||
|
|
||||||
allocCell _ = Precise <$> fresh
|
allocCell _ = Precise <$> fresh
|
||||||
derefCell _ = pure . getLast . unLatest
|
derefCell _ = pure . getLast . unLatest
|
||||||
|
|
||||||
-- | 'Monovariant' locations allocate one 'Address' per unique variable name, and dereference once per stored value, nondeterministically.
|
-- | 'Monovariant' addresses allocate one address per unique variable name, and dereference once per stored value, nondeterministically.
|
||||||
instance Member NonDet effects => Addressable Monovariant effects where
|
instance Member NonDet effects => Addressable Monovariant effects where
|
||||||
type Cell Monovariant = All
|
type Cell Monovariant = All
|
||||||
|
|
||||||
allocCell = pure . Monovariant
|
allocCell = pure . Monovariant
|
||||||
derefCell _ = traverse (foldMapA pure) . nonEmpty . toList
|
derefCell _ = traverse (foldMapA pure) . nonEmpty . toList
|
||||||
|
|
||||||
-- | 'Located' locations allocate & dereference using the underlying location, contextualizing locations with the current 'PackageInfo' & 'ModuleInfo'.
|
-- | 'Located' addresses allocate & dereference using the underlying address, contextualizing addresses with the current 'PackageInfo' & 'ModuleInfo'.
|
||||||
instance (Addressable location effects, Members '[Reader ModuleInfo, Reader PackageInfo] effects) => Addressable (Located location) effects where
|
instance (Addressable address effects, Member (Reader ModuleInfo) effects, Member (Reader PackageInfo) effects) => Addressable (Located address) effects where
|
||||||
type Cell (Located location) = Cell location
|
type Cell (Located address) = Cell address
|
||||||
|
|
||||||
allocCell name = relocate (Located <$> allocCell name <*> currentPackage <*> currentModule)
|
allocCell name = relocate (Located <$> allocCell name <*> currentPackage <*> currentModule)
|
||||||
derefCell (Address (Located loc _ _)) = relocate . derefCell (Address loc)
|
derefCell (Located loc _ _) = relocate . derefCell loc
|
||||||
|
|
||||||
relocate :: Evaluator location value effects a -> Evaluator (Located location) value effects a
|
instance Addressable address effects => Addressable (Hole address) effects where
|
||||||
|
type Cell (Hole address) = Cell address
|
||||||
|
|
||||||
|
allocCell name = relocate (Total <$> allocCell name)
|
||||||
|
derefCell (Total loc) = relocate . derefCell loc
|
||||||
|
derefCell Partial = const (pure Nothing)
|
||||||
|
|
||||||
|
relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a
|
||||||
relocate = raiseEff . lowerEff
|
relocate = raiseEff . lowerEff
|
||||||
|
@ -12,5 +12,5 @@ import Control.Abstract.TermEvaluator
|
|||||||
import Data.Abstract.Configuration
|
import Data.Abstract.Configuration
|
||||||
|
|
||||||
-- | Get the current 'Configuration' with a passed-in term.
|
-- | Get the current 'Configuration' with a passed-in term.
|
||||||
getConfiguration :: Members '[Reader (Live location value), State (Environment location), State (Heap location (Cell location) value)] effects => term -> TermEvaluator term location value effects (Configuration term location (Cell location) value)
|
getConfiguration :: (Member (Reader (Live address)) effects, Member (State (Environment address)) effects, Member (State (Heap address (Cell address) value)) effects) => term -> TermEvaluator term address value effects (Configuration term address (Cell address) value)
|
||||||
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap
|
getConfiguration term = Configuration term <$> TermEvaluator askRoots <*> TermEvaluator getEnv <*> TermEvaluator getHeap
|
||||||
|
@ -45,11 +45,11 @@ withCurrentSpan = local . const
|
|||||||
|
|
||||||
|
|
||||||
-- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.
|
-- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.
|
||||||
withCurrentSrcLoc :: (Effectful m, Members '[Reader ModuleInfo, Reader Span] effects) => SrcLoc -> m effects a -> m effects a
|
withCurrentSrcLoc :: (Effectful m, Member (Reader ModuleInfo) effects, Member (Reader Span) effects) => SrcLoc -> m effects a -> m effects a
|
||||||
withCurrentSrcLoc loc = withCurrentModule (moduleInfoFromSrcLoc loc) . withCurrentSpan (spanFromSrcLoc loc)
|
withCurrentSrcLoc loc = withCurrentModule (moduleInfoFromSrcLoc loc) . withCurrentSpan (spanFromSrcLoc loc)
|
||||||
|
|
||||||
-- | Run an action with locally replaced 'ModuleInfo' & 'Span' derived from the Haskell call stack.
|
-- | Run an action with locally replaced 'ModuleInfo' & 'Span' derived from the Haskell call stack.
|
||||||
--
|
--
|
||||||
-- This is suitable for contextualizing builtins & other functionality intended for use from client code but defined in Haskell source.
|
-- This is suitable for contextualizing builtins & other functionality intended for use from client code but defined in Haskell source.
|
||||||
withCurrentCallStack :: (Effectful m, Members '[Reader ModuleInfo, Reader Span] effects) => CallStack -> m effects a -> m effects a
|
withCurrentCallStack :: (Effectful m, Member (Reader ModuleInfo) effects, Member (Reader Span) effects) => CallStack -> m effects a -> m effects a
|
||||||
withCurrentCallStack = maybe id (withCurrentSrcLoc . snd) . listToMaybe . getCallStack
|
withCurrentCallStack = maybe id (withCurrentSrcLoc . snd) . listToMaybe . getCallStack
|
||||||
|
@ -3,14 +3,12 @@ module Control.Abstract.Environment
|
|||||||
( Environment
|
( Environment
|
||||||
, getEnv
|
, getEnv
|
||||||
, putEnv
|
, putEnv
|
||||||
, modifyEnv
|
|
||||||
, withEnv
|
, withEnv
|
||||||
, defaultEnvironment
|
|
||||||
, withDefaultEnvironment
|
, withDefaultEnvironment
|
||||||
, fullEnvironment
|
|
||||||
, localEnv
|
|
||||||
, localize
|
|
||||||
, lookupEnv
|
, lookupEnv
|
||||||
|
, bind
|
||||||
|
, bindAll
|
||||||
|
, locally
|
||||||
, EnvironmentError(..)
|
, EnvironmentError(..)
|
||||||
, freeVariableError
|
, freeVariableError
|
||||||
, runEnvironmentError
|
, runEnvironmentError
|
||||||
@ -18,72 +16,70 @@ module Control.Abstract.Environment
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
import Data.Abstract.Address
|
|
||||||
import Data.Abstract.Environment as Env
|
import Data.Abstract.Environment as Env
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | Retrieve the environment.
|
-- | Retrieve the environment.
|
||||||
getEnv :: Member (State (Environment location)) effects => Evaluator location value effects (Environment location)
|
getEnv :: Member (State (Environment address)) effects => Evaluator address value effects (Environment address)
|
||||||
getEnv = get
|
getEnv = get
|
||||||
|
|
||||||
-- | Set the environment.
|
-- | Set the environment.
|
||||||
putEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects ()
|
putEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects ()
|
||||||
putEnv = put
|
putEnv = put
|
||||||
|
|
||||||
-- | Update the global environment.
|
-- | Update the global environment.
|
||||||
modifyEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects ()
|
modifyEnv :: Member (State (Environment address)) effects => (Environment address -> Environment address) -> Evaluator address value effects ()
|
||||||
modifyEnv = modify'
|
modifyEnv = modify'
|
||||||
|
|
||||||
-- | Sets the environment for the lifetime of the given action.
|
-- | Sets the environment for the lifetime of the given action.
|
||||||
withEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a
|
withEnv :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a
|
||||||
withEnv = localState . const
|
withEnv = localState . const
|
||||||
|
|
||||||
|
|
||||||
-- | Retrieve the default environment.
|
-- | Retrieve the default environment.
|
||||||
defaultEnvironment :: Member (Reader (Environment location)) effects => Evaluator location value effects (Environment location)
|
defaultEnvironment :: Member (Reader (Environment address)) effects => Evaluator address value effects (Environment address)
|
||||||
defaultEnvironment = ask
|
defaultEnvironment = ask
|
||||||
|
|
||||||
-- | Set the default environment for the lifetime of an action.
|
-- | Set the default environment for the lifetime of an action.
|
||||||
-- Usually only invoked in a top-level evaluation function.
|
-- Usually only invoked in a top-level evaluation function.
|
||||||
withDefaultEnvironment :: Member (Reader (Environment location)) effects => Environment location -> Evaluator location value effects a -> Evaluator location value effects a
|
withDefaultEnvironment :: Member (Reader (Environment address)) effects => Environment address -> Evaluator address value effects a -> Evaluator address value effects a
|
||||||
withDefaultEnvironment e = local (const e)
|
withDefaultEnvironment e = local (const e)
|
||||||
|
|
||||||
-- | Obtain an environment that is the composition of the current and default environments.
|
|
||||||
-- Useful for debugging.
|
|
||||||
fullEnvironment :: Members '[Reader (Environment location), State (Environment location)] effects => Evaluator location value effects (Environment location)
|
|
||||||
fullEnvironment = mergeEnvs <$> getEnv <*> defaultEnvironment
|
|
||||||
|
|
||||||
-- | Run an action with a locally-modified environment.
|
|
||||||
localEnv :: Member (State (Environment location)) effects => (Environment location -> Environment location) -> Evaluator location value effects a -> Evaluator location value effects a
|
|
||||||
localEnv f a = do
|
|
||||||
modifyEnv (f . Env.push)
|
|
||||||
result <- a
|
|
||||||
result <$ modifyEnv Env.pop
|
|
||||||
|
|
||||||
-- | Run a computation in a new local environment.
|
|
||||||
localize :: Member (State (Environment location)) effects => Evaluator location value effects a -> Evaluator location value effects a
|
|
||||||
localize = localEnv id
|
|
||||||
|
|
||||||
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
|
-- | Look a 'Name' up in the current environment, trying the default environment if no value is found.
|
||||||
lookupEnv :: Members '[Reader (Environment location), State (Environment location)] effects => Name -> Evaluator location value effects (Maybe (Address location value))
|
lookupEnv :: (Member (Reader (Environment address)) effects, Member (State (Environment address)) effects) => Name -> Evaluator address value effects (Maybe address)
|
||||||
lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
|
lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment)
|
||||||
|
|
||||||
|
-- | Bind a 'Name' to an 'Address' in the current scope.
|
||||||
|
bind :: Member (State (Environment address)) effects => Name -> address -> Evaluator address value effects ()
|
||||||
|
bind name = modifyEnv . Env.insert name
|
||||||
|
|
||||||
|
-- | Bind all of the names from an 'Environment' in the current scope.
|
||||||
|
bindAll :: Member (State (Environment address)) effects => Environment address -> Evaluator address value effects ()
|
||||||
|
bindAll = foldr ((>>) . uncurry bind) (pure ()) . pairs
|
||||||
|
|
||||||
|
-- | Run an action in a new local environment.
|
||||||
|
locally :: Member (State (Environment address)) effects => Evaluator address value effects a -> Evaluator address value effects a
|
||||||
|
locally a = do
|
||||||
|
modifyEnv Env.push
|
||||||
|
a' <- a
|
||||||
|
a' <$ modifyEnv Env.pop
|
||||||
|
|
||||||
|
|
||||||
-- | Errors involving the environment.
|
-- | Errors involving the environment.
|
||||||
data EnvironmentError value return where
|
data EnvironmentError address return where
|
||||||
FreeVariable :: Name -> EnvironmentError value value
|
FreeVariable :: Name -> EnvironmentError address address
|
||||||
|
|
||||||
deriving instance Eq (EnvironmentError value return)
|
deriving instance Eq (EnvironmentError address return)
|
||||||
deriving instance Show (EnvironmentError value return)
|
deriving instance Show (EnvironmentError address return)
|
||||||
instance Show1 (EnvironmentError value) where liftShowsPrec _ _ = showsPrec
|
instance Show1 (EnvironmentError address) where liftShowsPrec _ _ = showsPrec
|
||||||
instance Eq1 (EnvironmentError value) where liftEq _ (FreeVariable n1) (FreeVariable n2) = n1 == n2
|
instance Eq1 (EnvironmentError address) where liftEq _ (FreeVariable n1) (FreeVariable n2) = n1 == n2
|
||||||
|
|
||||||
freeVariableError :: Member (Resumable (EnvironmentError value)) effects => Name -> Evaluator location value effects value
|
freeVariableError :: Member (Resumable (EnvironmentError address)) effects => Name -> Evaluator address value effects address
|
||||||
freeVariableError = throwResumable . FreeVariable
|
freeVariableError = throwResumable . FreeVariable
|
||||||
|
|
||||||
runEnvironmentError :: Effectful (m location value) => m location value (Resumable (EnvironmentError value) ': effects) a -> m location value effects (Either (SomeExc (EnvironmentError value)) a)
|
runEnvironmentError :: Effectful (m address value) => m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects (Either (SomeExc (EnvironmentError address)) a)
|
||||||
runEnvironmentError = runResumable
|
runEnvironmentError = runResumable
|
||||||
|
|
||||||
runEnvironmentErrorWith :: Effectful (m location value) => (forall resume . EnvironmentError value resume -> m location value effects resume) -> m location value (Resumable (EnvironmentError value) ': effects) a -> m location value effects a
|
runEnvironmentErrorWith :: Effectful (m address value) => (forall resume . EnvironmentError address resume -> m address value effects resume) -> m address value (Resumable (EnvironmentError address) ': effects) a -> m address value effects a
|
||||||
runEnvironmentErrorWith = runResumableWith
|
runEnvironmentErrorWith = runResumableWith
|
||||||
|
@ -16,6 +16,7 @@ module Control.Abstract.Evaluator
|
|||||||
|
|
||||||
import Control.Monad.Effect as X
|
import Control.Monad.Effect as X
|
||||||
import Control.Monad.Effect.Fresh as X
|
import Control.Monad.Effect.Fresh as X
|
||||||
|
import Control.Monad.Effect.Internal
|
||||||
import Control.Monad.Effect.NonDet as X
|
import Control.Monad.Effect.NonDet as X
|
||||||
import Control.Monad.Effect.Reader as X
|
import Control.Monad.Effect.Reader as X
|
||||||
import Control.Monad.Effect.Resumable as X
|
import Control.Monad.Effect.Resumable as X
|
||||||
@ -23,15 +24,15 @@ import Control.Monad.Effect.State as X
|
|||||||
import Control.Monad.Effect.Trace as X
|
import Control.Monad.Effect.Trace as X
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | An 'Evaluator' is a thin wrapper around 'Eff' with (phantom) type parameters for the location, term, and value types.
|
-- | An 'Evaluator' is a thin wrapper around 'Eff' 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 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.
|
-- 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 location value effects a = Evaluator { runEvaluator :: Eff effects a }
|
newtype Evaluator address value effects a = Evaluator { runEvaluator :: Eff effects a }
|
||||||
deriving (Applicative, Effectful, Functor, Monad)
|
deriving (Applicative, Effectful, Functor, Monad)
|
||||||
|
|
||||||
deriving instance Member NonDet effects => Alternative (Evaluator location value effects)
|
deriving instance Member NonDet effects => Alternative (Evaluator address value effects)
|
||||||
|
|
||||||
|
|
||||||
-- Effects
|
-- Effects
|
||||||
@ -43,14 +44,14 @@ data Return value resume where
|
|||||||
deriving instance Eq value => Eq (Return value a)
|
deriving instance Eq value => Eq (Return value a)
|
||||||
deriving instance Show value => Show (Return value a)
|
deriving instance Show value => Show (Return value a)
|
||||||
|
|
||||||
earlyReturn :: Member (Return value) effects => value -> Evaluator location value effects value
|
earlyReturn :: Member (Return value) effects => value -> Evaluator address value effects value
|
||||||
earlyReturn = send . Return
|
earlyReturn = send . Return
|
||||||
|
|
||||||
catchReturn :: Member (Return value) effects => Evaluator location value effects a -> (forall x . Return value x -> Evaluator location value effects a) -> Evaluator location value effects a
|
catchReturn :: Member (Return value) effects => Evaluator address value effects a -> (forall x . Return value x -> Evaluator address value effects a) -> Evaluator address value effects a
|
||||||
catchReturn action handler = interpose pure (\ ret _ -> handler ret) action
|
catchReturn action handler = interpose pure (\ ret _ -> handler ret) action
|
||||||
|
|
||||||
runReturn :: Evaluator location value (Return value ': effects) value -> Evaluator location value effects value
|
runReturn :: Effectful (m address value) => m address value (Return value ': effects) value -> m address value effects value
|
||||||
runReturn = relay pure (\ (Return value) _ -> pure value)
|
runReturn = raiseHandler (relay pure (\ (Return value) _ -> pure value))
|
||||||
|
|
||||||
|
|
||||||
-- | Effects for control flow around loops (breaking and continuing).
|
-- | Effects for control flow around loops (breaking and continuing).
|
||||||
@ -61,16 +62,16 @@ data LoopControl value resume where
|
|||||||
deriving instance Eq value => Eq (LoopControl value a)
|
deriving instance Eq value => Eq (LoopControl value a)
|
||||||
deriving instance Show value => Show (LoopControl value a)
|
deriving instance Show value => Show (LoopControl value a)
|
||||||
|
|
||||||
throwBreak :: Member (LoopControl value) effects => value -> Evaluator location value effects value
|
throwBreak :: Member (LoopControl value) effects => value -> Evaluator address value effects value
|
||||||
throwBreak = send . Break
|
throwBreak = send . Break
|
||||||
|
|
||||||
throwContinue :: Member (LoopControl value) effects => value -> Evaluator location value effects value
|
throwContinue :: Member (LoopControl value) effects => value -> Evaluator address value effects value
|
||||||
throwContinue = send . Continue
|
throwContinue = send . Continue
|
||||||
|
|
||||||
catchLoopControl :: Member (LoopControl value) effects => Evaluator location value effects a -> (forall x . LoopControl value x -> Evaluator location value effects a) -> Evaluator location value effects a
|
catchLoopControl :: Member (LoopControl value) effects => Evaluator address value effects a -> (forall x . LoopControl value x -> Evaluator address value effects a) -> Evaluator address value effects a
|
||||||
catchLoopControl action handler = interpose pure (\ control _ -> handler control) action
|
catchLoopControl action handler = interpose pure (\ control _ -> handler control) action
|
||||||
|
|
||||||
runLoopControl :: Evaluator location value (LoopControl value ': effects) value -> Evaluator location value effects value
|
runLoopControl :: Effectful (m address value) => m address value (LoopControl value ': effects) value -> m address value effects value
|
||||||
runLoopControl = relay pure (\ eff _ -> case eff of
|
runLoopControl = raiseHandler (relay pure (\ eff _ -> case eff of
|
||||||
Break value -> pure value
|
Break value -> pure value
|
||||||
Continue value -> pure value)
|
Continue value -> pure value))
|
||||||
|
@ -8,26 +8,25 @@ module Control.Abstract.Exports
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
import Data.Abstract.Address
|
|
||||||
import Data.Abstract.Exports
|
import Data.Abstract.Exports
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
|
|
||||||
-- | Get the global export state.
|
-- | Get the global export state.
|
||||||
getExports :: Member (State (Exports location)) effects => Evaluator location value effects (Exports location)
|
getExports :: Member (State (Exports address)) effects => Evaluator address value effects (Exports address)
|
||||||
getExports = get
|
getExports = get
|
||||||
|
|
||||||
-- | Set the global export state.
|
-- | Set the global export state.
|
||||||
putExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects ()
|
putExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects ()
|
||||||
putExports = put
|
putExports = put
|
||||||
|
|
||||||
-- | Update the global export state.
|
-- | Update the global export state.
|
||||||
modifyExports :: Member (State (Exports location)) effects => (Exports location -> Exports location) -> Evaluator location value effects ()
|
modifyExports :: Member (State (Exports address)) effects => (Exports address -> Exports address) -> Evaluator address value effects ()
|
||||||
modifyExports = modify'
|
modifyExports = modify'
|
||||||
|
|
||||||
-- | Add an export to the global export state.
|
-- | Add an export to the global export state.
|
||||||
addExport :: Member (State (Exports location)) effects => Name -> Name -> Maybe (Address location value) -> Evaluator location value effects ()
|
addExport :: Member (State (Exports address)) effects => Name -> Name -> Maybe address -> Evaluator address value effects ()
|
||||||
addExport name alias = modifyExports . insert name alias
|
addExport name alias = modifyExports . insert name alias
|
||||||
|
|
||||||
-- | Sets the global export state for the lifetime of the given action.
|
-- | Sets the global export state for the lifetime of the given action.
|
||||||
withExports :: Member (State (Exports location)) effects => Exports location -> Evaluator location value effects a -> Evaluator location value effects a
|
withExports :: Member (State (Exports address)) effects => Exports address -> Evaluator address value effects a -> Evaluator address value effects a
|
||||||
withExports = localState . const
|
withExports = localState . const
|
||||||
|
@ -1,77 +0,0 @@
|
|||||||
{-# LANGUAGE GADTs, TypeOperators #-}
|
|
||||||
module Control.Abstract.Goto
|
|
||||||
( GotoTable
|
|
||||||
, Label
|
|
||||||
, label
|
|
||||||
, goto
|
|
||||||
, Goto(..)
|
|
||||||
, runGoto
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Abstract.Evaluator
|
|
||||||
import Control.Monad.Effect (Eff)
|
|
||||||
import qualified Data.IntMap as IntMap
|
|
||||||
import Prelude hiding (fail)
|
|
||||||
import Prologue
|
|
||||||
|
|
||||||
type GotoTable inner value = IntMap.IntMap (Eff (Goto inner value ': inner) value)
|
|
||||||
|
|
||||||
-- | The type of labels.
|
|
||||||
-- TODO: This should be rolled into 'Name' and tracked in the environment, both so that we can abstract over labels like any other location, and so that we can garbage collect unreachable labels.
|
|
||||||
type Label = Int
|
|
||||||
|
|
||||||
|
|
||||||
-- | Allocate a 'Label' for the given @term@.
|
|
||||||
--
|
|
||||||
-- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms.
|
|
||||||
label :: Evaluator location value (Goto effects value ': effects) value -> Evaluator location value (Goto effects value ': effects) Label
|
|
||||||
label = send . Label . lowerEff
|
|
||||||
|
|
||||||
-- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated.
|
|
||||||
goto :: Label -> Evaluator location value (Goto effects value ': effects) (Evaluator location value (Goto effects value ': effects) value)
|
|
||||||
goto = fmap raiseEff . send . Goto
|
|
||||||
|
|
||||||
|
|
||||||
-- | 'Goto' effects embed an 'Eff' action which can be run in the environment under the 'Goto' itself.
|
|
||||||
--
|
|
||||||
-- It’s tempting to try to use a 'Member' constraint to require a 'Goto' effect:
|
|
||||||
--
|
|
||||||
-- @
|
|
||||||
-- foo :: Member (Goto effects a) effects => Eff effects a
|
|
||||||
-- @
|
|
||||||
--
|
|
||||||
-- However, using this type would require that the type of the effect list include a reference to itself, which is forbidden by the occurs check: we wouldn’t be able to write a handler for 'Goto' if it could be used at that type. Instead, one can either use a smaller, statically known effect list inside the 'Goto', e.g. @Member (Goto outer) inner@ where @outer@ is a suffix of @inner@ (and with some massaging to raise the @outer@ actions into the @inner@ context), or use 'Goto' when it’s statically known to be the head of the list: @Eff (Goto rest a ': rest) b@. In either case, the 'Eff' actions embedded in the effect are themselves able to contain further 'Goto' effects,
|
|
||||||
data Goto effects value return where
|
|
||||||
Label :: Eff (Goto effects value ': effects) value -> Goto effects value Label
|
|
||||||
Goto :: Label -> Goto effects value (Eff (Goto effects value ': effects) value)
|
|
||||||
|
|
||||||
-- | Run a 'Goto' effect in terms of a 'State' effect holding a 'GotoTable', accessed via wrap/unwrap functions.
|
|
||||||
--
|
|
||||||
-- The wrap/unwrap functions are necessary in order for ghc to be able to typecheck the table, since it necessarily contains references to its own effect list. Since @GotoTable (… ': State (GotoTable … value) ': …) value@ can’t be written, and a recursive type equality constraint won’t typecheck, callers will need to employ a @newtype@ to break the self-reference. The effect list of the table the @newtype@ contains will include all of the effects between the 'Goto' effect and the 'State' effect (including the 'State' but not the 'Goto'). E.g. if the 'State' is the next effect, a valid wrapper would be∷
|
|
||||||
--
|
|
||||||
-- @
|
|
||||||
-- newtype Gotos effects value = Gotos { getGotos :: GotoTable (State (Gotos effects value) ': effects) value }
|
|
||||||
-- @
|
|
||||||
--
|
|
||||||
-- Callers can then evaluate the high-level 'Goto' effect by passing @Gotos@ and @getGotos@ to 'runGoto'.
|
|
||||||
runGoto :: Members '[ Fail
|
|
||||||
, Fresh
|
|
||||||
, State table
|
|
||||||
] effects
|
|
||||||
=> (GotoTable effects value -> table)
|
|
||||||
-> (table -> GotoTable effects value)
|
|
||||||
-> Evaluator location value (Goto effects value ': effects) a
|
|
||||||
-> Evaluator location value effects a
|
|
||||||
runGoto from to = interpret (\ goto -> do
|
|
||||||
table <- to <$> getTable
|
|
||||||
case goto of
|
|
||||||
Label action -> do
|
|
||||||
supremum <- fresh
|
|
||||||
supremum <$ putTable (from (IntMap.insert supremum action table))
|
|
||||||
Goto label -> maybeM (raiseEff (fail ("unknown label: " <> show label))) (IntMap.lookup label table))
|
|
||||||
|
|
||||||
getTable :: Member (State table) effects => Evaluator location value effects table
|
|
||||||
getTable = get
|
|
||||||
|
|
||||||
putTable :: Member (State table) effects => table -> Evaluator location value effects ()
|
|
||||||
putTable = put
|
|
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||||
module Control.Abstract.Heap
|
module Control.Abstract.Heap
|
||||||
( Heap
|
( Heap
|
||||||
, getHeap
|
, getHeap
|
||||||
@ -22,126 +22,123 @@ module Control.Abstract.Heap
|
|||||||
import Control.Abstract.Addressable
|
import Control.Abstract.Addressable
|
||||||
import Control.Abstract.Environment
|
import Control.Abstract.Environment
|
||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
import Data.Abstract.Address
|
import Control.Monad.Effect.Internal
|
||||||
import Data.Abstract.Environment
|
|
||||||
import Data.Abstract.Heap
|
import Data.Abstract.Heap
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import Data.Semigroup.Reducer
|
import Data.Semigroup.Reducer
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | Retrieve the heap.
|
-- | Retrieve the heap.
|
||||||
getHeap :: Member (State (Heap location (Cell location) value)) effects => Evaluator location value effects (Heap location (Cell location) value)
|
getHeap :: Member (State (Heap address (Cell address) value)) effects => Evaluator address value effects (Heap address (Cell address) value)
|
||||||
getHeap = get
|
getHeap = get
|
||||||
|
|
||||||
-- | Set the heap.
|
-- | Set the heap.
|
||||||
putHeap :: Member (State (Heap location (Cell location) value)) effects => Heap location (Cell location) value -> Evaluator location value effects ()
|
putHeap :: Member (State (Heap address (Cell address) value)) effects => Heap address (Cell address) value -> Evaluator address value effects ()
|
||||||
putHeap = put
|
putHeap = put
|
||||||
|
|
||||||
-- | Update the heap.
|
-- | Update the heap.
|
||||||
modifyHeap :: Member (State (Heap location (Cell location) value)) effects => (Heap location (Cell location) value -> Heap location (Cell location) value) -> Evaluator location value effects ()
|
modifyHeap :: Member (State (Heap address (Cell address) value)) effects => (Heap address (Cell address) value -> Heap address (Cell address) value) -> Evaluator address value effects ()
|
||||||
modifyHeap = modify'
|
modifyHeap = modify'
|
||||||
|
|
||||||
|
|
||||||
alloc :: Member (Allocator location value) effects => Name -> Evaluator location value effects (Address location value)
|
alloc :: forall address value effects . Member (Allocator address value) effects => Name -> Evaluator address value effects address
|
||||||
alloc = send . Alloc
|
alloc = send . Alloc @address @value
|
||||||
|
|
||||||
-- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized.
|
-- | Dereference the given address in the heap, or fail if the address is uninitialized.
|
||||||
deref :: Member (Allocator location value) effects => Address location value -> Evaluator location value effects value
|
deref :: Member (Allocator address value) effects => address -> Evaluator address value effects value
|
||||||
deref = send . Deref
|
deref = send . Deref
|
||||||
|
|
||||||
|
|
||||||
-- | Write a value to the given 'Address' in the 'Store'.
|
-- | Write a value to the given address in the 'Store'.
|
||||||
assign :: ( Member (State (Heap location (Cell location) value)) effects
|
assign :: ( Member (State (Heap address (Cell address) value)) effects
|
||||||
, Ord location
|
, Ord address
|
||||||
, Reducer value (Cell location value)
|
, Reducer value (Cell address value)
|
||||||
)
|
)
|
||||||
=> Address location value
|
=> address
|
||||||
-> value
|
-> value
|
||||||
-> Evaluator location value effects ()
|
-> Evaluator address value effects ()
|
||||||
assign address = modifyHeap . heapInsert address
|
assign address = modifyHeap . heapInsert address
|
||||||
|
|
||||||
|
|
||||||
-- | Look up or allocate an address for a 'Name'.
|
-- | Look up or allocate an address for a 'Name'.
|
||||||
lookupOrAlloc :: Members '[ Allocator location value
|
lookupOrAlloc :: ( Member (Allocator address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
] effects
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> Evaluator location value effects (Address location value)
|
-> Evaluator address value effects address
|
||||||
lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
|
lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure
|
||||||
|
|
||||||
|
|
||||||
letrec :: ( Members '[ Allocator location value
|
letrec :: ( Member (Allocator address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
] effects
|
, Ord address
|
||||||
, Ord location
|
, Reducer value (Cell address value)
|
||||||
, Reducer value (Cell location value)
|
|
||||||
)
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
-> Evaluator location value effects (value, Address location value)
|
-> Evaluator address value effects (value, address)
|
||||||
letrec name body = do
|
letrec name body = do
|
||||||
addr <- lookupOrAlloc name
|
addr <- lookupOrAlloc name
|
||||||
v <- localEnv (insert name addr) body
|
v <- locally (bind name addr *> body)
|
||||||
assign addr v
|
assign addr v
|
||||||
pure (v, addr)
|
pure (v, addr)
|
||||||
|
|
||||||
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
|
-- Lookup/alloc a name passing the address to a body evaluated in a new local environment.
|
||||||
letrec' :: Members '[ Allocator location value
|
letrec' :: ( Member (Allocator address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
] effects
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> (Address location value -> Evaluator location value effects value)
|
-> (address -> Evaluator address value effects value)
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
letrec' name body = do
|
letrec' name body = do
|
||||||
addr <- lookupOrAlloc name
|
addr <- lookupOrAlloc name
|
||||||
v <- localEnv id (body addr)
|
v <- locally (body addr)
|
||||||
v <$ modifyEnv (insert name addr)
|
v <$ bind name addr
|
||||||
|
|
||||||
|
|
||||||
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
|
-- | Look up and dereference the given 'Name', throwing an exception for free variables.
|
||||||
variable :: Members '[ Allocator location value
|
variable :: ( Member (Allocator address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, Resumable (EnvironmentError value)
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
)
|
||||||
] effects
|
|
||||||
=> Name
|
=> Name
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
variable name = lookupEnv name >>= maybe (freeVariableError name) deref
|
variable name = lookupEnv name >>= maybeM (freeVariableError name) >>= deref
|
||||||
|
|
||||||
|
|
||||||
-- Effects
|
-- Effects
|
||||||
|
|
||||||
data Allocator location value return where
|
data Allocator address value return where
|
||||||
Alloc :: Name -> Allocator location value (Address location value)
|
Alloc :: Name -> Allocator address value address
|
||||||
Deref :: Address location value -> Allocator location value value
|
Deref :: address -> Allocator address value value
|
||||||
|
|
||||||
runAllocator :: (Addressable location effects, Members '[Resumable (AddressError location value), State (Heap location (Cell location) value)] effects) => Evaluator location value (Allocator location value ': effects) a -> Evaluator location value effects a
|
runAllocator :: (Addressable address effects, Effectful (m address value), Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => m address value (Allocator address value ': effects) a -> m address value effects a
|
||||||
runAllocator = interpret (\ eff -> case eff of
|
runAllocator = raiseHandler (interpret (\ eff -> case eff of
|
||||||
Alloc name -> Address <$> allocCell name
|
Alloc name -> lowerEff $ allocCell name
|
||||||
Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)))
|
Deref addr -> lowerEff $ heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))))
|
||||||
|
|
||||||
|
|
||||||
data AddressError location value resume where
|
data AddressError address value resume where
|
||||||
UnallocatedAddress :: Address location value -> AddressError location value (Cell location value)
|
UnallocatedAddress :: address -> AddressError address value (Cell address value)
|
||||||
UninitializedAddress :: Address location value -> AddressError location value value
|
UninitializedAddress :: address -> AddressError address value value
|
||||||
|
|
||||||
deriving instance Eq location => Eq (AddressError location value resume)
|
deriving instance Eq address => Eq (AddressError address value resume)
|
||||||
deriving instance Show location => Show (AddressError location value resume)
|
deriving instance Show address => Show (AddressError address value resume)
|
||||||
instance Show location => Show1 (AddressError location value) where
|
instance Show address => Show1 (AddressError address value) where
|
||||||
liftShowsPrec _ _ = showsPrec
|
liftShowsPrec _ _ = showsPrec
|
||||||
instance Eq location => Eq1 (AddressError location value) where
|
instance Eq address => Eq1 (AddressError address value) where
|
||||||
liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b
|
liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b
|
||||||
liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b
|
liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b
|
||||||
liftEq _ _ _ = False
|
liftEq _ _ _ = False
|
||||||
|
|
||||||
|
|
||||||
runAddressError :: Effectful (m location value) => m location value (Resumable (AddressError location value) ': effects) a -> m location value effects (Either (SomeExc (AddressError location value)) a)
|
runAddressError :: Effectful (m address value) => m address value (Resumable (AddressError address value) ': effects) a -> m address value effects (Either (SomeExc (AddressError address value)) a)
|
||||||
runAddressError = runResumable
|
runAddressError = runResumable
|
||||||
|
|
||||||
runAddressErrorWith :: Effectful (m location value) => (forall resume . AddressError location value resume -> m location value effects resume) -> m location value (Resumable (AddressError location value) ': effects) a -> m location value effects a
|
runAddressErrorWith :: Effectful (m address value) => (forall resume . AddressError address value resume -> m address value effects resume) -> m address value (Resumable (AddressError address value) ': effects) a -> m address value effects a
|
||||||
runAddressErrorWith = runResumableWith
|
runAddressErrorWith = runResumableWith
|
||||||
|
15
src/Control/Abstract/Hole.hs
Normal file
15
src/Control/Abstract/Hole.hs
Normal file
@ -0,0 +1,15 @@
|
|||||||
|
module Control.Abstract.Hole where
|
||||||
|
|
||||||
|
class AbstractHole a where
|
||||||
|
hole :: a
|
||||||
|
|
||||||
|
|
||||||
|
data Hole a = Partial | Total a
|
||||||
|
deriving (Foldable, Functor, Eq, Ord, Show, Traversable)
|
||||||
|
|
||||||
|
instance AbstractHole (Hole a) where
|
||||||
|
hole = Partial
|
||||||
|
|
||||||
|
toMaybe :: Hole a -> Maybe a
|
||||||
|
toMaybe Partial = Nothing
|
||||||
|
toMaybe (Total a) = Just a
|
@ -26,49 +26,49 @@ import Data.Language
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load.
|
-- | Retrieve an evaluated module, if any. The outer 'Maybe' indicates whether we’ve begun loading the module or not, while the inner 'Maybe' indicates whether we’ve completed loading it or not. Thus, @Nothing@ means we’ve never tried to load it, @Just Nothing@ means we’ve started but haven’t yet finished loading it, and @Just (Just (env, value))@ indicates the result of a completed load.
|
||||||
lookupModule :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Maybe (Environment location, value)))
|
lookupModule :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Maybe (Environment address, value)))
|
||||||
lookupModule = send . Lookup
|
lookupModule = send . Lookup
|
||||||
|
|
||||||
-- | Resolve a list of module paths to a possible module table entry.
|
-- | Resolve a list of module paths to a possible module table entry.
|
||||||
resolve :: Member (Modules location value) effects => [FilePath] -> Evaluator location value effects (Maybe ModulePath)
|
resolve :: Member (Modules address value) effects => [FilePath] -> Evaluator address value effects (Maybe ModulePath)
|
||||||
resolve = sendModules . Resolve
|
resolve = sendModules . Resolve
|
||||||
|
|
||||||
listModulesInDir :: Member (Modules location value) effects => FilePath -> Evaluator location value effects [ModulePath]
|
listModulesInDir :: Member (Modules address value) effects => FilePath -> Evaluator address value effects [ModulePath]
|
||||||
listModulesInDir = sendModules . List
|
listModulesInDir = sendModules . List
|
||||||
|
|
||||||
|
|
||||||
-- | Require/import another module by name and return its environment and value.
|
-- | Require/import another module by name and return its environment and value.
|
||||||
--
|
--
|
||||||
-- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
|
-- Looks up the module's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module.
|
||||||
require :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value))
|
require :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
|
||||||
require path = lookupModule path >>= maybeM (load path)
|
require path = lookupModule path >>= maybeM (load path)
|
||||||
|
|
||||||
-- | Load another module by name and return its environment and value.
|
-- | Load another module by name and return its environment and value.
|
||||||
--
|
--
|
||||||
-- Always loads/evaluates.
|
-- Always loads/evaluates.
|
||||||
load :: Member (Modules location value) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value))
|
load :: Member (Modules address value) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
|
||||||
load = send . Load
|
load = send . Load
|
||||||
|
|
||||||
|
|
||||||
data Modules location value return where
|
data Modules address value return where
|
||||||
Load :: ModulePath -> Modules location value (Maybe (Environment location, value))
|
Load :: ModulePath -> Modules address value (Maybe (Environment address, value))
|
||||||
Lookup :: ModulePath -> Modules location value (Maybe (Maybe (Environment location, value)))
|
Lookup :: ModulePath -> Modules address value (Maybe (Maybe (Environment address, value)))
|
||||||
Resolve :: [FilePath] -> Modules location value (Maybe ModulePath)
|
Resolve :: [FilePath] -> Modules address value (Maybe ModulePath)
|
||||||
List :: FilePath -> Modules location value [ModulePath]
|
List :: FilePath -> Modules address value [ModulePath]
|
||||||
|
|
||||||
sendModules :: Member (Modules location value) effects => Modules location value return -> Evaluator location value effects return
|
sendModules :: Member (Modules address value) effects => Modules address value return -> Evaluator address value effects return
|
||||||
sendModules = send
|
sendModules = send
|
||||||
|
|
||||||
runModules :: forall term location value effects a
|
runModules :: forall term address value effects a
|
||||||
. Members '[ Resumable (LoadError location value)
|
. ( Member (Resumable (LoadError address value)) effects
|
||||||
, State (ModuleTable (Maybe (Environment location, value)))
|
, Member (State (ModuleTable (Maybe (Environment address, value)))) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
)
|
||||||
=> (Module term -> Evaluator location value (Modules location value ': effects) (Environment location, value))
|
=> (Module term -> Evaluator address value (Modules address value ': effects) (Environment address, value))
|
||||||
-> Evaluator location value (Modules location value ': effects) a
|
-> Evaluator address value (Modules address value ': effects) a
|
||||||
-> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a
|
-> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a
|
||||||
runModules evaluateModule = go
|
runModules evaluateModule = go
|
||||||
where go :: forall a . Evaluator location value (Modules location value ': effects) a -> Evaluator location value (Reader (ModuleTable [Module term]) ': effects) a
|
where go :: forall a . Evaluator address value (Modules address value ': effects) a -> Evaluator address value (Reader (ModuleTable [Module term]) ': effects) a
|
||||||
go = reinterpret (\ m -> case m of
|
go = reinterpret (\ m -> case m of
|
||||||
Load name -> askModuleTable @term >>= maybe (moduleNotFound name) (runMerging . foldMap (Merging . evalAndCache)) . ModuleTable.lookup name
|
Load name -> askModuleTable @term >>= maybe (moduleNotFound name) (runMerging . foldMap (Merging . evalAndCache)) . ModuleTable.lookup name
|
||||||
where
|
where
|
||||||
@ -89,49 +89,49 @@ runModules evaluateModule = go
|
|||||||
pure (find isMember names)
|
pure (find isMember names)
|
||||||
List dir -> modulePathsInDir dir <$> askModuleTable @term)
|
List dir -> modulePathsInDir dir <$> askModuleTable @term)
|
||||||
|
|
||||||
getModuleTable :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => Evaluator location value effects (ModuleTable (Maybe (Environment location, value)))
|
getModuleTable :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => Evaluator address value effects (ModuleTable (Maybe (Environment address, value)))
|
||||||
getModuleTable = get
|
getModuleTable = get
|
||||||
|
|
||||||
cacheModule :: Member (State (ModuleTable (Maybe (Environment location, value)))) effects => ModulePath -> Maybe (Environment location, value) -> Evaluator location value effects (Maybe (Environment location, value))
|
cacheModule :: Member (State (ModuleTable (Maybe (Environment address, value)))) effects => ModulePath -> Maybe (Environment address, value) -> Evaluator address value effects (Maybe (Environment address, value))
|
||||||
cacheModule path result = modify' (ModuleTable.insert path result) $> result
|
cacheModule path result = modify' (ModuleTable.insert path result) $> result
|
||||||
|
|
||||||
askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator location value effects (ModuleTable [Module term])
|
askModuleTable :: Member (Reader (ModuleTable [Module term])) effects => Evaluator address value effects (ModuleTable [Module term])
|
||||||
askModuleTable = ask
|
askModuleTable = ask
|
||||||
|
|
||||||
|
|
||||||
newtype Merging m location value = Merging { runMerging :: m (Maybe (Environment location, value)) }
|
newtype Merging m address value = Merging { runMerging :: m (Maybe (Environment address, value)) }
|
||||||
|
|
||||||
instance Applicative m => Semigroup (Merging m location value) where
|
instance Applicative m => Semigroup (Merging m address value) where
|
||||||
Merging a <> Merging b = Merging (merge <$> a <*> b)
|
Merging a <> Merging b = Merging (merge <$> a <*> b)
|
||||||
where merge a b = mergeJusts <$> a <*> b <|> a <|> b
|
where merge a b = mergeJusts <$> a <*> b <|> a <|> b
|
||||||
mergeJusts (env1, _) (env2, v) = (mergeEnvs env1 env2, v)
|
mergeJusts (env1, _) (env2, v) = (mergeEnvs env1 env2, v)
|
||||||
|
|
||||||
instance Applicative m => Monoid (Merging m location value) where
|
instance Applicative m => Monoid (Merging m address value) where
|
||||||
mappend = (<>)
|
mappend = (<>)
|
||||||
mempty = Merging (pure Nothing)
|
mempty = Merging (pure Nothing)
|
||||||
|
|
||||||
|
|
||||||
-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.
|
-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.
|
||||||
data LoadError location value resume where
|
data LoadError address value resume where
|
||||||
ModuleNotFound :: ModulePath -> LoadError location value (Maybe (Environment location, value))
|
ModuleNotFound :: ModulePath -> LoadError address value (Maybe (Environment address, value))
|
||||||
|
|
||||||
deriving instance Eq (LoadError location value resume)
|
deriving instance Eq (LoadError address value resume)
|
||||||
deriving instance Show (LoadError location value resume)
|
deriving instance Show (LoadError address value resume)
|
||||||
instance Show1 (LoadError location value) where
|
instance Show1 (LoadError address value) where
|
||||||
liftShowsPrec _ _ = showsPrec
|
liftShowsPrec _ _ = showsPrec
|
||||||
instance Eq1 (LoadError location value) where
|
instance Eq1 (LoadError address value) where
|
||||||
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
|
liftEq _ (ModuleNotFound a) (ModuleNotFound b) = a == b
|
||||||
|
|
||||||
moduleNotFound :: Member (Resumable (LoadError location value)) effects => ModulePath -> Evaluator location value effects (Maybe (Environment location, value))
|
moduleNotFound :: Member (Resumable (LoadError address value)) effects => ModulePath -> Evaluator address value effects (Maybe (Environment address, value))
|
||||||
moduleNotFound = throwResumable . ModuleNotFound
|
moduleNotFound = throwResumable . ModuleNotFound
|
||||||
|
|
||||||
resumeLoadError :: Member (Resumable (LoadError location value)) effects => Evaluator location value effects a -> (forall resume . LoadError location value resume -> Evaluator location value effects resume) -> Evaluator location value effects a
|
resumeLoadError :: Member (Resumable (LoadError address value)) effects => Evaluator address value effects a -> (forall resume . LoadError address value resume -> Evaluator address value effects resume) -> Evaluator address value effects a
|
||||||
resumeLoadError = catchResumable
|
resumeLoadError = catchResumable
|
||||||
|
|
||||||
runLoadError :: Effectful (m location value) => m location value (Resumable (LoadError location value) ': effects) a -> m location value effects (Either (SomeExc (LoadError location value)) a)
|
runLoadError :: Effectful (m address value) => m address value (Resumable (LoadError address value) ': effects) a -> m address value effects (Either (SomeExc (LoadError address value)) a)
|
||||||
runLoadError = runResumable
|
runLoadError = runResumable
|
||||||
|
|
||||||
runLoadErrorWith :: Effectful (m location value) => (forall resume . LoadError location value resume -> m location value effects resume) -> m location value (Resumable (LoadError location value) ': effects) a -> m location value effects a
|
runLoadErrorWith :: Effectful (m address value) => (forall resume . LoadError address value resume -> m address value effects resume) -> m address value (Resumable (LoadError address value) ': effects) a -> m address value effects a
|
||||||
runLoadErrorWith = runResumableWith
|
runLoadErrorWith = runResumableWith
|
||||||
|
|
||||||
|
|
||||||
|
@ -6,7 +6,6 @@ import Control.Abstract.Environment
|
|||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
import Control.Abstract.Heap
|
import Control.Abstract.Heap
|
||||||
import Control.Abstract.Value
|
import Control.Abstract.Value
|
||||||
import Data.Abstract.Environment
|
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import Data.ByteString.Char8 (pack, unpack)
|
import Data.ByteString.Char8 (pack, unpack)
|
||||||
import Data.Semigroup.Reducer hiding (unit)
|
import Data.Semigroup.Reducer hiding (unit)
|
||||||
@ -14,48 +13,44 @@ import Data.Semilattice.Lower
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
builtin :: ( HasCallStack
|
builtin :: ( HasCallStack
|
||||||
, Members '[ Allocator location value
|
, Member (Allocator address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader ModuleInfo) effects
|
||||||
, Reader ModuleInfo
|
, Member (Reader Span) effects
|
||||||
, Reader Span
|
, Member (State (Environment address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
, State (Heap location (Cell location) value)
|
, Ord address
|
||||||
] effects
|
, Reducer value (Cell address value)
|
||||||
, Ord location
|
|
||||||
, Reducer value (Cell location value)
|
|
||||||
)
|
)
|
||||||
=> String
|
=> String
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
-> Evaluator location value effects ()
|
-> Evaluator address value effects ()
|
||||||
builtin n def = withCurrentCallStack callStack $ do
|
builtin s def = withCurrentCallStack callStack $ do
|
||||||
let name' = name ("__semantic_" <> pack n)
|
let name' = name (pack ("__semantic_" <> s))
|
||||||
addr <- alloc name'
|
addr <- alloc name'
|
||||||
modifyEnv (insert name' addr)
|
bind name' addr
|
||||||
def >>= assign addr
|
def >>= assign addr
|
||||||
|
|
||||||
lambda :: (AbstractFunction location value effects, Member Fresh effects)
|
lambda :: (AbstractFunction address value effects, Member Fresh effects)
|
||||||
=> Set Name
|
=> (Name -> Evaluator address value effects value)
|
||||||
-> (Name -> Evaluator location value effects value)
|
-> Evaluator address value effects value
|
||||||
-> Evaluator location value effects value
|
lambda body = do
|
||||||
lambda fvs body = do
|
|
||||||
var <- nameI <$> fresh
|
var <- nameI <$> fresh
|
||||||
closure [var] fvs (body var)
|
closure [var] lowerBound (body var)
|
||||||
|
|
||||||
defineBuiltins :: ( AbstractValue location value effects
|
defineBuiltins :: ( AbstractValue address value effects
|
||||||
, HasCallStack
|
, HasCallStack
|
||||||
, Members '[ Allocator location value
|
, Member (Allocator address value) effects
|
||||||
, Fresh
|
, Member Fresh effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, Reader ModuleInfo
|
, Member (Reader ModuleInfo) effects
|
||||||
, Reader Span
|
, Member (Reader Span) effects
|
||||||
, Resumable (EnvironmentError value)
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
, Ord address
|
||||||
, Ord location
|
, Reducer value (Cell address value)
|
||||||
, Reducer value (Cell location value)
|
|
||||||
)
|
)
|
||||||
=> Evaluator location value effects ()
|
=> Evaluator address value effects ()
|
||||||
defineBuiltins =
|
defineBuiltins =
|
||||||
builtin "print" (lambda lowerBound (\ v -> variable v >>= asString >>= trace . unpack >> unit))
|
builtin "print" (lambda (\ v -> variable v >>= asString >>= trace . unpack >> pure unit))
|
||||||
|
@ -9,9 +9,9 @@ import Data.Abstract.Live
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | Retrieve the local 'Live' set.
|
-- | Retrieve the local 'Live' set.
|
||||||
askRoots :: Member (Reader (Live location value)) effects => Evaluator location value effects (Live location value)
|
askRoots :: Member (Reader (Live address)) effects => Evaluator address value effects (Live address)
|
||||||
askRoots = ask
|
askRoots = ask
|
||||||
|
|
||||||
-- | Run a computation with the given 'Live' set added to the local root set.
|
-- | Run a computation with the given 'Live' set added to the local root set.
|
||||||
extraRoots :: (Member (Reader (Live location value)) effects, Ord location) => Live location value -> Evaluator location value effects a -> Evaluator location value effects a
|
extraRoots :: (Member (Reader (Live address)) effects, Ord address) => Live address -> Evaluator address value effects a -> Evaluator address value effects a
|
||||||
extraRoots roots = local (<> roots)
|
extraRoots roots = local (<> roots)
|
||||||
|
@ -19,11 +19,11 @@ import Prologue
|
|||||||
-- | Evaluators specialized to some specific term type.
|
-- | Evaluators specialized to some specific term type.
|
||||||
--
|
--
|
||||||
-- This is used to constrain the term type so that inference for analyses can resolve it correctly, but should not be used for any of the term-agonstic machinery like builtins, Evaluatable instances, the mechanics of the heap & environment, etc.
|
-- This is used to constrain the term type so that inference for analyses can resolve it correctly, but should not be used for any of the term-agonstic machinery like builtins, Evaluatable instances, the mechanics of the heap & environment, etc.
|
||||||
newtype TermEvaluator term location value effects a = TermEvaluator { runTermEvaluator :: Evaluator location value effects a }
|
newtype TermEvaluator term address value effects a = TermEvaluator { runTermEvaluator :: Evaluator address value effects a }
|
||||||
deriving (Applicative, Effectful, Functor, Monad)
|
deriving (Applicative, Effectful, Functor, Monad)
|
||||||
|
|
||||||
deriving instance Member NonDet effects => Alternative (TermEvaluator term location value effects)
|
deriving instance Member NonDet effects => Alternative (TermEvaluator term address value effects)
|
||||||
|
|
||||||
|
|
||||||
raiseHandler :: (Evaluator location value effects a -> Evaluator location value effects' a') -> (TermEvaluator term location value effects a -> TermEvaluator term location value effects' a')
|
raiseHandler :: (Evaluator address value effects a -> Evaluator address value effects' a') -> (TermEvaluator term address value effects a -> TermEvaluator term address value effects' a')
|
||||||
raiseHandler f = TermEvaluator . f . runTermEvaluator
|
raiseHandler f = TermEvaluator . f . runTermEvaluator
|
||||||
|
@ -1,8 +1,8 @@
|
|||||||
{-# LANGUAGE GADTs, Rank2Types #-}
|
{-# LANGUAGE GADTs, Rank2Types #-}
|
||||||
module Control.Abstract.Value
|
module Control.Abstract.Value
|
||||||
( AbstractValue(..)
|
( AbstractValue(..)
|
||||||
|
, AbstractIntro(..)
|
||||||
, AbstractFunction(..)
|
, AbstractFunction(..)
|
||||||
, AbstractHole(..)
|
|
||||||
, Comparator(..)
|
, Comparator(..)
|
||||||
, asBool
|
, asBool
|
||||||
, while
|
, while
|
||||||
@ -19,7 +19,6 @@ import Control.Abstract.Addressable
|
|||||||
import Control.Abstract.Environment
|
import Control.Abstract.Environment
|
||||||
import Control.Abstract.Evaluator
|
import Control.Abstract.Evaluator
|
||||||
import Control.Abstract.Heap
|
import Control.Abstract.Heap
|
||||||
import Data.Abstract.Address (Address)
|
|
||||||
import Data.Abstract.Environment as Env
|
import Data.Abstract.Environment as Env
|
||||||
import Data.Abstract.Live (Live)
|
import Data.Abstract.Live (Live)
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
@ -41,164 +40,162 @@ data Comparator
|
|||||||
= Concrete (forall a . Ord a => a -> a -> Bool)
|
= Concrete (forall a . Ord a => a -> a -> Bool)
|
||||||
| Generalized
|
| Generalized
|
||||||
|
|
||||||
class AbstractHole value where
|
class Show value => AbstractFunction address value effects where
|
||||||
hole :: value
|
|
||||||
|
|
||||||
|
|
||||||
class Show value => AbstractFunction location value effects where
|
|
||||||
-- | Build a closure (a binder like a lambda or method definition).
|
-- | Build a closure (a binder like a lambda or method definition).
|
||||||
closure :: [Name] -- ^ The parameter names.
|
closure :: [Name] -- ^ The parameter names.
|
||||||
-> Set Name -- ^ The set of free variables to close over.
|
-> Set Name -- ^ The set of free variables to close over.
|
||||||
-> Evaluator location value effects value -- ^ The evaluator for the body of the closure.
|
-> Evaluator address value effects value -- ^ The evaluator for the body of the closure.
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
-- | Evaluate an application (like a function call).
|
-- | Evaluate an application (like a function call).
|
||||||
call :: value -> [Evaluator location value effects value] -> Evaluator location value effects value
|
call :: value -> [Evaluator address value effects value] -> Evaluator address value effects value
|
||||||
|
|
||||||
|
|
||||||
|
class Show value => AbstractIntro value where
|
||||||
|
-- | Construct an abstract unit value.
|
||||||
|
-- TODO: This might be the same as the empty tuple for some value types
|
||||||
|
unit :: value
|
||||||
|
|
||||||
|
-- | Construct an abstract boolean value.
|
||||||
|
boolean :: Bool -> value
|
||||||
|
|
||||||
|
-- | Construct an abstract string value.
|
||||||
|
string :: ByteString -> value
|
||||||
|
|
||||||
|
-- | Construct a self-evaluating symbol value.
|
||||||
|
-- TODO: Should these be interned in some table to provide stronger uniqueness guarantees?
|
||||||
|
symbol :: ByteString -> value
|
||||||
|
|
||||||
|
-- | Construct an abstract integral value.
|
||||||
|
integer :: Integer -> value
|
||||||
|
|
||||||
|
-- | Construct a floating-point value.
|
||||||
|
float :: Scientific -> value
|
||||||
|
|
||||||
|
-- | Construct a rational value.
|
||||||
|
rational :: Rational -> value
|
||||||
|
|
||||||
|
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
|
||||||
|
multiple :: [value] -> value
|
||||||
|
|
||||||
|
-- | Construct a key-value pair for use in a hash.
|
||||||
|
kvPair :: value -> value -> value
|
||||||
|
|
||||||
|
-- | Construct a hash out of pairs.
|
||||||
|
hash :: [(value, value)] -> value
|
||||||
|
|
||||||
|
-- | Construct the nil/null datatype.
|
||||||
|
null :: value
|
||||||
|
|
||||||
|
|
||||||
-- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
|
-- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc).
|
||||||
--
|
--
|
||||||
-- This allows us to abstract the choice of whether to evaluate under binders for different value types.
|
-- This allows us to abstract the choice of whether to evaluate under binders for different value types.
|
||||||
class AbstractFunction location value effects => AbstractValue location value effects where
|
class (AbstractFunction address value effects, AbstractIntro value) => AbstractValue address value effects where
|
||||||
-- | Construct an abstract unit value.
|
|
||||||
-- TODO: This might be the same as the empty tuple for some value types
|
|
||||||
unit :: Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Construct an abstract integral value.
|
|
||||||
integer :: Integer -> Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Lift a unary operator over a 'Num' to a function on 'value's.
|
-- | Lift a unary operator over a 'Num' to a function on 'value's.
|
||||||
liftNumeric :: (forall a . Num a => a -> a)
|
liftNumeric :: (forall a . Num a => a -> a)
|
||||||
-> (value -> Evaluator location value effects value)
|
-> (value -> Evaluator address value effects value)
|
||||||
|
|
||||||
-- | Lift a pair of binary operators to a function on 'value's.
|
-- | 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
|
-- You usually pass the same operator as both arguments, except in the cases where
|
||||||
-- Haskell provides different functions for integral and fractional operations, such
|
-- Haskell provides different functions for integral and fractional operations, such
|
||||||
-- as division, exponentiation, and modulus.
|
-- as division, exponentiation, and modulus.
|
||||||
liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber)
|
liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber)
|
||||||
-> (value -> value -> Evaluator location value effects value)
|
-> (value -> value -> Evaluator address value effects value)
|
||||||
|
|
||||||
-- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
|
-- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values.
|
||||||
liftComparison :: Comparator -> (value -> value -> Evaluator location value effects value)
|
liftComparison :: Comparator -> (value -> value -> Evaluator address value effects value)
|
||||||
|
|
||||||
-- | Lift a unary bitwise operator to values. This is usually 'complement'.
|
-- | Lift a unary bitwise operator to values. This is usually 'complement'.
|
||||||
liftBitwise :: (forall a . Bits a => a -> a)
|
liftBitwise :: (forall a . Bits a => a -> a)
|
||||||
-> (value -> Evaluator location value effects value)
|
-> (value -> Evaluator address value effects value)
|
||||||
|
|
||||||
-- | Lift a binary bitwise operator to values. The Integral constraint is
|
-- | Lift a binary bitwise operator to values. The Integral constraint is
|
||||||
-- necessary to satisfy implementation details of Haskell left/right shift,
|
-- necessary to satisfy implementation details of Haskell left/right shift,
|
||||||
-- but it's fine, since these are only ever operating on integral values.
|
-- but it's fine, since these are only ever operating on integral values.
|
||||||
liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a)
|
liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a)
|
||||||
-> (value -> value -> Evaluator location value effects value)
|
-> (value -> value -> Evaluator address value effects value)
|
||||||
|
|
||||||
-- | Construct an abstract boolean value.
|
|
||||||
boolean :: Bool -> Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Construct an abstract string value.
|
|
||||||
string :: ByteString -> Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Construct a self-evaluating symbol value.
|
|
||||||
-- TODO: Should these be interned in some table to provide stronger uniqueness guarantees?
|
|
||||||
symbol :: ByteString -> Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Construct a floating-point value.
|
|
||||||
float :: Scientific -> Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Construct a rational value.
|
|
||||||
rational :: Rational -> Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Construct an N-ary tuple of multiple (possibly-disjoint) values
|
|
||||||
multiple :: [value] -> Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Construct an array of zero or more values.
|
-- | Construct an array of zero or more values.
|
||||||
array :: [value] -> Evaluator location value effects value
|
array :: [value] -> Evaluator address value effects value
|
||||||
|
|
||||||
-- | Construct a key-value pair for use in a hash.
|
|
||||||
kvPair :: value -> value -> Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Extract the contents of a key-value pair as a tuple.
|
-- | Extract the contents of a key-value pair as a tuple.
|
||||||
asPair :: value -> Evaluator location value effects (value, value)
|
asPair :: value -> Evaluator address value effects (value, value)
|
||||||
|
|
||||||
-- | Construct a hash out of pairs.
|
|
||||||
hash :: [(value, value)] -> Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | Extract a 'ByteString' from a given value.
|
-- | Extract a 'ByteString' from a given value.
|
||||||
asString :: value -> Evaluator location value effects ByteString
|
asString :: value -> Evaluator address value effects ByteString
|
||||||
|
|
||||||
-- | Eliminate boolean values. TODO: s/boolean/truthy
|
-- | Eliminate boolean values. TODO: s/boolean/truthy
|
||||||
ifthenelse :: value -> Evaluator location value effects a -> Evaluator location value effects a -> Evaluator location value effects a
|
ifthenelse :: value -> Evaluator address value effects a -> Evaluator address value effects a -> Evaluator address value effects a
|
||||||
|
|
||||||
-- | Construct the nil/null datatype.
|
|
||||||
null :: Evaluator location value effects value
|
|
||||||
|
|
||||||
-- | @index x i@ computes @x[i]@, with zero-indexing.
|
-- | @index x i@ computes @x[i]@, with zero-indexing.
|
||||||
index :: value -> value -> Evaluator location value effects value
|
index :: value -> value -> Evaluator address value effects value
|
||||||
|
|
||||||
-- | Build a class value from a name and environment.
|
-- | Build a class value from a name and environment.
|
||||||
klass :: Name -- ^ The new class's identifier
|
klass :: Name -- ^ The new class's identifier
|
||||||
-> [value] -- ^ A list of superclasses
|
-> [value] -- ^ A list of superclasses
|
||||||
-> Environment location -- ^ The environment to capture
|
-> Environment address -- ^ The environment to capture
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
|
|
||||||
-- | Build a namespace value from a name and environment stack
|
-- | Build a namespace value from a name and environment stack
|
||||||
--
|
--
|
||||||
-- Namespaces model closures with monoidal environments.
|
-- Namespaces model closures with monoidal environments.
|
||||||
namespace :: Name -- ^ The namespace's identifier
|
namespace :: Name -- ^ The namespace's identifier
|
||||||
-> Environment location -- ^ The environment to mappend
|
-> Environment address -- ^ The environment to mappend
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
|
|
||||||
-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
|
-- | Extract the environment from any scoped object (e.g. classes, namespaces, etc).
|
||||||
scopedEnvironment :: value -> Evaluator location value effects (Maybe (Environment location))
|
scopedEnvironment :: value -> Evaluator address value effects (Maybe (Environment address))
|
||||||
|
|
||||||
-- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
|
-- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion.
|
||||||
--
|
--
|
||||||
-- The function argument takes an action which recurs through the loop.
|
-- The function argument takes an action which recurs through the loop.
|
||||||
loop :: (Evaluator location value effects value -> Evaluator location value effects value) -> Evaluator location value effects value
|
loop :: (Evaluator address value effects value -> Evaluator address value effects value) -> Evaluator address value effects value
|
||||||
|
|
||||||
|
|
||||||
-- | Extract a 'Bool' from a given value.
|
-- | Extract a 'Bool' from a given value.
|
||||||
asBool :: AbstractValue location value effects => value -> Evaluator location value effects Bool
|
asBool :: AbstractValue address value effects => value -> Evaluator address value effects Bool
|
||||||
asBool value = ifthenelse value (pure True) (pure False)
|
asBool value = ifthenelse value (pure True) (pure False)
|
||||||
|
|
||||||
-- | C-style for loops.
|
-- | C-style for loops.
|
||||||
forLoop :: ( AbstractValue location value effects
|
forLoop :: ( AbstractValue address value effects
|
||||||
, Member (State (Environment location)) effects
|
, Member (State (Environment address)) effects
|
||||||
)
|
)
|
||||||
=> Evaluator location value effects value -- ^ Initial statement
|
=> Evaluator address value effects value -- ^ Initial statement
|
||||||
-> Evaluator location value effects value -- ^ Condition
|
-> Evaluator address value effects value -- ^ Condition
|
||||||
-> Evaluator location value effects value -- ^ Increment/stepper
|
-> Evaluator address value effects value -- ^ Increment/stepper
|
||||||
-> Evaluator location value effects value -- ^ Body
|
-> Evaluator address value effects value -- ^ Body
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
forLoop initial cond step body =
|
forLoop initial cond step body =
|
||||||
localize (initial *> while cond (body *> step))
|
locally (initial *> while cond (body *> step))
|
||||||
|
|
||||||
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
|
-- | The fundamental looping primitive, built on top of 'ifthenelse'.
|
||||||
while :: AbstractValue location value effects
|
while :: AbstractValue address value effects
|
||||||
=> Evaluator location value effects value
|
=> Evaluator address value effects value
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
while cond body = loop $ \ continue -> do
|
while cond body = loop $ \ continue -> do
|
||||||
this <- cond
|
this <- cond
|
||||||
ifthenelse this (body *> continue) unit
|
ifthenelse this (body *> continue) (pure unit)
|
||||||
|
|
||||||
-- | Do-while loop, built on top of while.
|
-- | Do-while loop, built on top of while.
|
||||||
doWhile :: AbstractValue location value effects
|
doWhile :: AbstractValue address value effects
|
||||||
=> Evaluator location value effects value
|
=> Evaluator address value effects value
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
doWhile body cond = loop $ \ continue -> body *> do
|
doWhile body cond = loop $ \ continue -> body *> do
|
||||||
this <- cond
|
this <- cond
|
||||||
ifthenelse this continue unit
|
ifthenelse this continue (pure unit)
|
||||||
|
|
||||||
makeNamespace :: ( AbstractValue location value effects
|
makeNamespace :: ( AbstractValue address value effects
|
||||||
, Member (State (Environment location)) effects
|
, Member (State (Environment address)) effects
|
||||||
, Member (State (Heap location (Cell location) value)) effects
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
, Ord location
|
, Ord address
|
||||||
, Reducer value (Cell location value)
|
, Reducer value (Cell address value)
|
||||||
)
|
)
|
||||||
=> Name
|
=> Name
|
||||||
-> Address location value
|
-> address
|
||||||
-> Maybe value
|
-> Maybe value
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
makeNamespace name addr super = do
|
makeNamespace name addr super = do
|
||||||
superEnv <- maybe (pure (Just lowerBound)) scopedEnvironment super
|
superEnv <- maybe (pure (Just lowerBound)) scopedEnvironment super
|
||||||
let env' = fromMaybe lowerBound superEnv
|
let env' = fromMaybe lowerBound superEnv
|
||||||
@ -208,47 +205,43 @@ makeNamespace name addr super = do
|
|||||||
|
|
||||||
|
|
||||||
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
|
-- | Evaluate a term within the context of the scoped environment of 'scopedEnvTerm'.
|
||||||
evaluateInScopedEnv :: ( AbstractValue location value effects
|
evaluateInScopedEnv :: ( AbstractValue address value effects
|
||||||
, Member (State (Environment location)) effects
|
, Member (State (Environment address)) effects
|
||||||
)
|
)
|
||||||
=> Evaluator location value effects value
|
=> Evaluator address value effects value
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
evaluateInScopedEnv scopedEnvTerm term = do
|
evaluateInScopedEnv scopedEnvTerm term = do
|
||||||
scopedEnv <- scopedEnvTerm >>= scopedEnvironment
|
scopedEnv <- scopedEnvTerm >>= scopedEnvironment
|
||||||
maybe term (flip localEnv term . mergeEnvs) scopedEnv
|
maybe term (\ env -> locally (bindAll env *> term)) scopedEnv
|
||||||
|
|
||||||
|
|
||||||
-- | Evaluates a 'Value' returning the referenced value
|
-- | Evaluates a 'Value' returning the referenced value
|
||||||
value :: ( AbstractValue location value effects
|
value :: ( AbstractValue address value effects
|
||||||
, Members '[ Allocator location value
|
, Member (Allocator address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, Resumable (EnvironmentError value)
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
|
||||||
] effects
|
|
||||||
)
|
)
|
||||||
=> ValueRef value
|
=> ValueRef value
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
value (LvalLocal var) = variable var
|
value (LvalLocal var) = variable var
|
||||||
value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop)
|
value (LvalMember obj prop) = evaluateInScopedEnv (pure obj) (variable prop)
|
||||||
value (Rval val) = pure val
|
value (Rval val) = pure val
|
||||||
|
|
||||||
-- | Evaluates a 'Subterm' to its rval
|
-- | Evaluates a 'Subterm' to its rval
|
||||||
subtermValue :: ( AbstractValue location value effects
|
subtermValue :: ( AbstractValue address value effects
|
||||||
, Members '[ Allocator location value
|
, Member (Allocator address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, Resumable (EnvironmentError value)
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
|
||||||
] effects
|
|
||||||
)
|
)
|
||||||
=> Subterm term (Evaluator location value effects (ValueRef value))
|
=> Subterm term (Evaluator address value effects (ValueRef value))
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
subtermValue = value <=< subtermRef
|
subtermValue = value <=< subtermRef
|
||||||
|
|
||||||
|
|
||||||
-- | Value types, e.g. closures, which can root a set of addresses.
|
-- | Value types, e.g. closures, which can root a set of addresses.
|
||||||
class ValueRoots location value where
|
class ValueRoots address value where
|
||||||
-- | Compute the set of addresses rooted by a given value.
|
-- | Compute the set of addresses rooted by a given value.
|
||||||
valueRoots :: value -> Live location value
|
valueRoots :: value -> Live address
|
||||||
|
@ -10,18 +10,6 @@ import Data.Semilattice.Lower
|
|||||||
import Data.Set as Set
|
import Data.Set as Set
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | An abstract address with a @location@ pointing to a variable of type @value@.
|
|
||||||
newtype Address location value = Address { unAddress :: location }
|
|
||||||
deriving (Eq, Ord)
|
|
||||||
|
|
||||||
instance Eq location => Eq1 (Address location) where liftEq _ a b = unAddress a == unAddress b
|
|
||||||
instance Ord location => Ord1 (Address location) where liftCompare _ a b = unAddress a `compare` unAddress b
|
|
||||||
instance Show location => Show1 (Address location) where liftShowsPrec _ _ = showsPrec
|
|
||||||
|
|
||||||
instance Show location => Show (Address location value) where
|
|
||||||
showsPrec d = showsPrec d . unAddress
|
|
||||||
|
|
||||||
|
|
||||||
-- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store.
|
-- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store.
|
||||||
newtype Precise = Precise { unPrecise :: Int }
|
newtype Precise = Precise { unPrecise :: Int }
|
||||||
deriving (Eq, Ord)
|
deriving (Eq, Ord)
|
||||||
@ -38,10 +26,10 @@ instance Show Monovariant where
|
|||||||
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
|
showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant
|
||||||
|
|
||||||
|
|
||||||
data Located location = Located
|
data Located address = Located
|
||||||
{ location :: location
|
{ address :: address
|
||||||
, locationPackage :: {-# UNPACK #-} !PackageInfo
|
, addressPackage :: {-# UNPACK #-} !PackageInfo
|
||||||
, locationModule :: !ModuleInfo
|
, addressModule :: !ModuleInfo
|
||||||
}
|
}
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
@ -9,30 +9,30 @@ import Data.Semilattice.Lower
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
|
-- | A map of 'Configuration's to 'Set's of resulting values & 'Heap's.
|
||||||
newtype Cache term location cell value = Cache { unCache :: Monoidal.Map (Configuration term location cell value) (Set (Cached location cell value)) }
|
newtype Cache term address cell value = Cache { unCache :: Monoidal.Map (Configuration term address cell value) (Set (Cached address cell value)) }
|
||||||
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term location cell value, Cached location cell value), Semigroup)
|
deriving (Eq, Lower, Monoid, Ord, Reducer (Configuration term address cell value, Cached address cell value), Semigroup)
|
||||||
|
|
||||||
data Cached location cell value = Cached
|
data Cached address cell value = Cached
|
||||||
{ cachedValue :: ValueRef value
|
{ cachedValue :: ValueRef value
|
||||||
, cachedHeap :: Heap location cell value
|
, cachedHeap :: Heap address cell value
|
||||||
}
|
}
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
|
||||||
type Cacheable term location cell value = (Ord (cell value), Ord location, Ord term, Ord value)
|
type Cacheable term address cell value = (Ord (cell value), Ord address, Ord term, Ord value)
|
||||||
|
|
||||||
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
|
-- | Look up the resulting value & 'Heap' for a given 'Configuration'.
|
||||||
cacheLookup :: Cacheable term location cell value => Configuration term location cell value -> Cache term location cell value -> Maybe (Set (Cached location cell value))
|
cacheLookup :: Cacheable term address cell value => Configuration term address cell value -> Cache term address cell value -> Maybe (Set (Cached address cell value))
|
||||||
cacheLookup key = Monoidal.lookup key . unCache
|
cacheLookup key = Monoidal.lookup key . unCache
|
||||||
|
|
||||||
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
|
-- | Set the resulting value & 'Heap' for a given 'Configuration', overwriting any previous entry.
|
||||||
cacheSet :: Cacheable term location cell value => Configuration term location cell value -> Set (Cached location cell value) -> Cache term location cell value -> Cache term location cell value
|
cacheSet :: Cacheable term address cell value => Configuration term address cell value -> Set (Cached address cell value) -> Cache term address cell value -> Cache term address cell value
|
||||||
cacheSet key value = Cache . Monoidal.insert key value . unCache
|
cacheSet key value = Cache . Monoidal.insert key value . unCache
|
||||||
|
|
||||||
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
|
-- | Insert the resulting value & 'Heap' for a given 'Configuration', appending onto any previous entry.
|
||||||
cacheInsert :: Cacheable term location cell value => Configuration term location cell value -> Cached location cell value -> Cache term location cell value -> Cache term location cell value
|
cacheInsert :: Cacheable term address cell value => Configuration term address cell value -> Cached address cell value -> Cache term address cell value -> Cache term address cell value
|
||||||
cacheInsert = curry cons
|
cacheInsert = curry cons
|
||||||
|
|
||||||
|
|
||||||
instance (Show term, Show location, Show (cell value), Show value) => Show (Cache term location cell value) where
|
instance (Show term, Show address, Show (cell value), Show value) => Show (Cache term address cell value) where
|
||||||
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache
|
showsPrec d = showsUnaryWith showsPrec "Cache" d . map (second toList) . Monoidal.pairs . unCache
|
||||||
|
@ -5,10 +5,10 @@ import Data.Abstract.Heap
|
|||||||
import Data.Abstract.Live
|
import Data.Abstract.Live
|
||||||
|
|
||||||
-- | A single point in a program’s execution.
|
-- | A single point in a program’s execution.
|
||||||
data Configuration term location cell value = Configuration
|
data Configuration term address cell value = Configuration
|
||||||
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
|
{ configurationTerm :: term -- ^ The “instruction,” i.e. the current term to evaluate.
|
||||||
, configurationRoots :: Live location value -- ^ The set of rooted addresses.
|
, configurationRoots :: Live address -- ^ The set of rooted addresses.
|
||||||
, configurationEnvironment :: Environment location -- ^ The environment binding any free variables in 'configurationTerm'.
|
, configurationEnvironment :: Environment address -- ^ The environment binding any free variables in 'configurationTerm'.
|
||||||
, configurationHeap :: Heap location cell value -- ^ The heap of values.
|
, configurationHeap :: Heap address cell value -- ^ The heap of values.
|
||||||
}
|
}
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
@ -1,7 +1,7 @@
|
|||||||
module Data.Abstract.Environment
|
module Data.Abstract.Environment
|
||||||
( Environment(..)
|
( Environment(..)
|
||||||
, addresses
|
, addresses
|
||||||
, bind
|
, intersect
|
||||||
, delete
|
, delete
|
||||||
, head
|
, head
|
||||||
, emptyEnv
|
, emptyEnv
|
||||||
@ -18,7 +18,6 @@ module Data.Abstract.Environment
|
|||||||
, roots
|
, roots
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Abstract.Address
|
|
||||||
import Data.Abstract.Live
|
import Data.Abstract.Live
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import Data.Align
|
import Data.Align
|
||||||
@ -29,38 +28,39 @@ import Prelude hiding (head, lookup)
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- $setup
|
-- $setup
|
||||||
-- >>> let bright = push (insert (name "foo") (Address (Precise 0)) emptyEnv)
|
-- >>> import Data.Abstract.Address
|
||||||
-- >>> let shadowed = insert (name "foo") (Address (Precise 1)) bright
|
-- >>> let bright = push (insert (name "foo") (Precise 0) emptyEnv)
|
||||||
|
-- >>> let shadowed = insert (name "foo") (Precise 1) bright
|
||||||
|
|
||||||
-- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
|
-- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
|
||||||
-- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific
|
-- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific
|
||||||
-- scope for "a", then the next, and so on.
|
-- scope for "a", then the next, and so on.
|
||||||
newtype Environment location = Environment { unEnvironment :: NonEmpty (Map.Map Name location) }
|
newtype Environment address = Environment { unEnvironment :: NonEmpty (Map.Map Name address) }
|
||||||
deriving (Eq, Ord)
|
deriving (Eq, Ord)
|
||||||
|
|
||||||
mergeEnvs :: Environment location -> Environment location -> Environment location
|
mergeEnvs :: Environment address -> Environment address -> Environment address
|
||||||
mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
|
mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
|
||||||
Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
|
Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
|
||||||
|
|
||||||
emptyEnv :: Environment location
|
emptyEnv :: Environment address
|
||||||
emptyEnv = Environment (lowerBound :| [])
|
emptyEnv = Environment (lowerBound :| [])
|
||||||
|
|
||||||
-- | Make and enter a new empty scope in the given environment.
|
-- | Make and enter a new empty scope in the given environment.
|
||||||
push :: Environment location -> Environment location
|
push :: Environment address -> Environment address
|
||||||
push (Environment (a :| as)) = Environment (mempty :| a : as)
|
push (Environment (a :| as)) = Environment (mempty :| a : as)
|
||||||
|
|
||||||
-- | Remove the frontmost scope.
|
-- | Remove the frontmost scope.
|
||||||
pop :: Environment location -> Environment location
|
pop :: Environment address -> Environment address
|
||||||
pop (Environment (_ :| [])) = emptyEnv
|
pop (Environment (_ :| [])) = emptyEnv
|
||||||
pop (Environment (_ :| a : as)) = Environment (a :| as)
|
pop (Environment (_ :| a : as)) = Environment (a :| as)
|
||||||
|
|
||||||
-- | Drop all scopes save for the frontmost one.
|
-- | Drop all scopes save for the frontmost one.
|
||||||
head :: Environment location -> Environment location
|
head :: Environment address -> Environment address
|
||||||
head (Environment (a :| _)) = Environment (a :| [])
|
head (Environment (a :| _)) = Environment (a :| [])
|
||||||
|
|
||||||
-- | Take the union of two environments. When duplicate keys are found in the
|
-- | Take the union of two environments. When duplicate keys are found in the
|
||||||
-- name to address map, the second definition wins.
|
-- name to address map, the second definition wins.
|
||||||
mergeNewer :: Environment location -> Environment location -> Environment location
|
mergeNewer :: Environment address -> Environment address -> Environment address
|
||||||
mergeNewer (Environment a) (Environment b) =
|
mergeNewer (Environment a) (Environment b) =
|
||||||
Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs))
|
Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs))
|
||||||
where
|
where
|
||||||
@ -72,45 +72,45 @@ mergeNewer (Environment a) (Environment b) =
|
|||||||
--
|
--
|
||||||
-- >>> pairs shadowed
|
-- >>> pairs shadowed
|
||||||
-- [("foo",Precise 1)]
|
-- [("foo",Precise 1)]
|
||||||
pairs :: Environment location -> [(Name, Address location value)]
|
pairs :: Environment address -> [(Name, address)]
|
||||||
pairs = map (second Address) . Map.toList . fold . unEnvironment
|
pairs = Map.toList . fold . unEnvironment
|
||||||
|
|
||||||
unpairs :: [(Name, Address location value)] -> Environment location
|
unpairs :: [(Name, address)] -> Environment address
|
||||||
unpairs = Environment . pure . Map.fromList . map (second unAddress)
|
unpairs = Environment . pure . Map.fromList
|
||||||
|
|
||||||
-- | Lookup a 'Name' in the environment.
|
-- | Lookup a 'Name' in the environment.
|
||||||
--
|
--
|
||||||
-- >>> lookup (name "foo") shadowed
|
-- >>> lookup (name "foo") shadowed
|
||||||
-- Just (Precise 1)
|
-- Just (Precise 1)
|
||||||
lookup :: Name -> Environment location -> Maybe (Address location value)
|
lookup :: Name -> Environment address -> Maybe address
|
||||||
lookup k = fmap Address . foldMapA (Map.lookup k) . unEnvironment
|
lookup name = foldMapA (Map.lookup name) . unEnvironment
|
||||||
|
|
||||||
-- | Insert a 'Name' in the environment.
|
-- | Insert a 'Name' in the environment.
|
||||||
insert :: Name -> Address location value -> Environment location -> Environment location
|
insert :: Name -> address -> Environment address -> Environment address
|
||||||
insert name (Address value) (Environment (a :| as)) = Environment (Map.insert name value a :| as)
|
insert name addr (Environment (a :| as)) = Environment (Map.insert name addr a :| as)
|
||||||
|
|
||||||
-- | Remove a 'Name' from the environment.
|
-- | Remove a 'Name' from the environment.
|
||||||
--
|
--
|
||||||
-- >>> delete (name "foo") shadowed
|
-- >>> delete (name "foo") shadowed
|
||||||
-- Environment []
|
-- Environment []
|
||||||
delete :: Name -> Environment location -> Environment location
|
delete :: Name -> Environment address -> Environment address
|
||||||
delete name = trim . Environment . fmap (Map.delete name) . unEnvironment
|
delete name = trim . Environment . fmap (Map.delete name) . unEnvironment
|
||||||
|
|
||||||
trim :: Environment location -> Environment location
|
trim :: Environment address -> Environment address
|
||||||
trim (Environment (a :| as)) = Environment (a :| filtered)
|
trim (Environment (a :| as)) = Environment (a :| filtered)
|
||||||
where filtered = filter (not . Map.null) as
|
where filtered = filter (not . Map.null) as
|
||||||
|
|
||||||
bind :: Foldable t => t Name -> Environment location -> Environment location
|
intersect :: Foldable t => t Name -> Environment address -> Environment address
|
||||||
bind names env = unpairs (mapMaybe lookupName (toList names))
|
intersect names env = unpairs (mapMaybe lookupName (toList names))
|
||||||
where
|
where
|
||||||
lookupName name = (,) name <$> lookup name env
|
lookupName name = (,) name <$> lookup name env
|
||||||
|
|
||||||
-- | Get all bound 'Name's in an environment.
|
-- | Get all bound 'Name's in an environment.
|
||||||
names :: Environment location -> [Name]
|
names :: Environment address -> [Name]
|
||||||
names = fmap fst . pairs
|
names = fmap fst . pairs
|
||||||
|
|
||||||
-- | Lookup and alias name-value bindings from an environment.
|
-- | Lookup and alias name-value bindings from an environment.
|
||||||
overwrite :: [(Name, Name)] -> Environment location -> Environment location
|
overwrite :: [(Name, Name)] -> Environment address -> Environment address
|
||||||
overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs
|
overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs
|
||||||
where
|
where
|
||||||
lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
|
lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
|
||||||
@ -118,14 +118,14 @@ overwrite pairs env = unpairs $ mapMaybe lookupAndAlias pairs
|
|||||||
-- | Retrieve the 'Live' set of addresses to which the given free variable names are bound.
|
-- | Retrieve the 'Live' set of addresses to which the given free variable names are bound.
|
||||||
--
|
--
|
||||||
-- Unbound names are silently dropped.
|
-- Unbound names are silently dropped.
|
||||||
roots :: (Ord location, Foldable t) => Environment location -> t Name -> Live location value
|
roots :: (Ord address, Foldable t) => Environment address -> t Name -> Live address
|
||||||
roots env = foldMap (maybe mempty liveSingleton . flip lookup env)
|
roots env names = addresses (names `intersect` env)
|
||||||
|
|
||||||
addresses :: Ord location => Environment location -> Live location value
|
addresses :: Ord address => Environment address -> Live address
|
||||||
addresses = fromAddresses . map snd . pairs
|
addresses = fromAddresses . map snd . pairs
|
||||||
|
|
||||||
|
|
||||||
instance Lower (Environment location) where lowerBound = emptyEnv
|
instance Lower (Environment address) where lowerBound = emptyEnv
|
||||||
|
|
||||||
instance Show location => Show (Environment location) where
|
instance Show address => Show (Environment address) where
|
||||||
showsPrec d = showsUnaryWith showsPrec "Environment" d . pairs
|
showsPrec d = showsUnaryWith showsPrec "Environment" d . pairs
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||||
module Data.Abstract.Evaluatable
|
module Data.Abstract.Evaluatable
|
||||||
( module X
|
( module X
|
||||||
, Evaluatable(..)
|
, Evaluatable(..)
|
||||||
@ -44,69 +44,64 @@ import Prologue
|
|||||||
|
|
||||||
-- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
|
-- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics.
|
||||||
class Evaluatable constr where
|
class Evaluatable constr where
|
||||||
eval :: ( EvaluatableConstraints location term value effects
|
eval :: ( EvaluatableConstraints address term value effects
|
||||||
, Member Fail effects
|
, Member Fail effects
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra constr term (Evaluator location value effects (ValueRef value))
|
=> SubtermAlgebra constr term (Evaluator address value effects (ValueRef value))
|
||||||
default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator location value effects (ValueRef value))
|
default eval :: (Member (Resumable (Unspecialized value)) effects, Show1 constr) => SubtermAlgebra constr term (Evaluator address value effects (ValueRef value))
|
||||||
eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
|
eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
|
||||||
|
|
||||||
type EvaluatableConstraints location term value effects =
|
type EvaluatableConstraints address term value effects =
|
||||||
( AbstractValue location value effects
|
( AbstractValue address value effects
|
||||||
, Declarations term
|
, Declarations term
|
||||||
, FreeVariables term
|
, FreeVariables term
|
||||||
, Members '[ Allocator location value
|
, Member (Allocator address value) effects
|
||||||
, LoopControl value
|
, Member (LoopControl value) effects
|
||||||
, Modules location value
|
, Member (Modules address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, Reader ModuleInfo
|
, Member (Reader ModuleInfo) effects
|
||||||
, Reader PackageInfo
|
, Member (Reader PackageInfo) effects
|
||||||
, Reader Span
|
, Member (Reader Span) effects
|
||||||
, Resumable (EnvironmentError value)
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, Resumable EvalError
|
, Member (Resumable EvalError) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
, Resumable (Unspecialized value)
|
, Member (Resumable (Unspecialized value)) effects
|
||||||
, Return value
|
, Member (Return value) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Exports location)
|
, Member (State (Exports address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
, Ord address
|
||||||
, Ord location
|
, Reducer value (Cell address value)
|
||||||
, Reducer value (Cell location value)
|
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
-- | Evaluate a given package.
|
-- | Evaluate a given package.
|
||||||
evaluatePackageWith :: forall location term value inner inner' outer
|
evaluatePackageWith :: forall address term value inner outer
|
||||||
-- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' locations require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out?
|
-- FIXME: It’d be nice if we didn’t have to mention 'Addressable' here at all, but 'Located' addresses require knowledge of 'currentModule' to run. Can we fix that? If not, can we factor this effect list out?
|
||||||
. ( Addressable location (Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
. ( Addressable address (Reader ModuleInfo ': Modules address value ': Reader Span ': Reader PackageInfo ': outer)
|
||||||
, Evaluatable (Base term)
|
, Evaluatable (Base term)
|
||||||
, EvaluatableConstraints location term value inner
|
, EvaluatableConstraints address term value inner
|
||||||
, Members '[ Fail
|
, Member Fail outer
|
||||||
, Fresh
|
, Member Fresh outer
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) outer
|
||||||
, Resumable (AddressError location value)
|
, Member (Resumable (AddressError address value)) outer
|
||||||
, Resumable (LoadError location value)
|
, Member (Resumable (LoadError address value)) outer
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) outer
|
||||||
, State (Exports location)
|
, Member (State (Exports address)) outer
|
||||||
, State (Heap location (Cell location) value)
|
, Member (State (Heap address (Cell address) value)) outer
|
||||||
, State (ModuleTable (Maybe (Environment location, value)))
|
, Member (State (ModuleTable (Maybe (Environment address, value)))) outer
|
||||||
, Trace
|
, Member Trace outer
|
||||||
] outer
|
|
||||||
, Recursive term
|
, Recursive term
|
||||||
, inner ~ (Goto inner' value ': inner')
|
, inner ~ (LoopControl value ': Return value ': Allocator address value ': Reader ModuleInfo ': Modules address value ': Reader Span ': Reader PackageInfo ': outer)
|
||||||
, inner' ~ (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
|
||||||
)
|
)
|
||||||
=> (SubtermAlgebra Module term (TermEvaluator term location value inner value) -> SubtermAlgebra Module term (TermEvaluator term location value inner value))
|
=> (SubtermAlgebra Module term (TermEvaluator term address value inner value) -> SubtermAlgebra Module term (TermEvaluator term address value inner value))
|
||||||
-> (SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term location value inner (ValueRef value)))
|
-> (SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)) -> SubtermAlgebra (Base term) term (TermEvaluator term address value inner (ValueRef value)))
|
||||||
-> Package term
|
-> Package term
|
||||||
-> TermEvaluator term location value outer [value]
|
-> TermEvaluator term address value outer [value]
|
||||||
evaluatePackageWith analyzeModule analyzeTerm package
|
evaluatePackageWith analyzeModule analyzeTerm package
|
||||||
= runReader (packageInfo package)
|
= runReader (packageInfo package)
|
||||||
. runReader lowerBound
|
. runReader lowerBound
|
||||||
. fmap fst
|
|
||||||
. runState (lowerBound :: Gotos location value (Reader Span ': Reader PackageInfo ': outer))
|
|
||||||
. runReader (packageModules (packageBody package))
|
. runReader (packageModules (packageBody package))
|
||||||
. withPrelude (packagePrelude (packageBody package))
|
. withPrelude (packagePrelude (packageBody package))
|
||||||
. raiseHandler (runModules (runTermEvaluator . evalModule))
|
. raiseHandler (runModules (runTermEvaluator . evalModule))
|
||||||
@ -124,15 +119,14 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
|||||||
. raiseHandler runAllocator
|
. raiseHandler runAllocator
|
||||||
. raiseHandler runReturn
|
. raiseHandler runReturn
|
||||||
. raiseHandler runLoopControl
|
. raiseHandler runLoopControl
|
||||||
. raiseHandler (runGoto Gotos getGotos)
|
|
||||||
|
|
||||||
evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term location value (Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer) value
|
evaluateEntryPoint :: ModulePath -> Maybe Name -> TermEvaluator term address value (Modules address value ': Reader Span ': Reader PackageInfo ': outer) value
|
||||||
evaluateEntryPoint m sym = runInModule (ModuleInfo m) . TermEvaluator $ do
|
evaluateEntryPoint m sym = runInModule (ModuleInfo m) . TermEvaluator $ do
|
||||||
v <- maybe unit (pure . snd) <$> require m
|
v <- maybe unit snd <$> require m
|
||||||
maybe v ((`call` []) <=< variable) sym
|
maybe (pure v) ((`call` []) <=< variable) sym
|
||||||
|
|
||||||
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do
|
evalPrelude prelude = raiseHandler (runModules (runTermEvaluator . evalModule)) $ do
|
||||||
_ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins *> unit))
|
_ <- runInModule moduleInfoFromCallStack (TermEvaluator (defineBuiltins $> unit))
|
||||||
fst <$> evalModule prelude
|
fst <$> evalModule prelude
|
||||||
|
|
||||||
withPrelude Nothing a = a
|
withPrelude Nothing a = a
|
||||||
@ -148,15 +142,12 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
|||||||
| otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env
|
| otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env
|
||||||
pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator getEnv)
|
pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> TermEvaluator getExports <*> TermEvaluator getEnv)
|
||||||
|
|
||||||
newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl value ': Return value ': Allocator location value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value outer) ': outer) value }
|
|
||||||
deriving (Lower)
|
|
||||||
|
|
||||||
|
|
||||||
-- | Isolate the given action with an empty global environment and exports.
|
-- | Isolate the given action with an empty global environment and exports.
|
||||||
isolate :: Members '[State (Environment location), State (Exports location)] effects => Evaluator location value effects a -> Evaluator location value effects a
|
isolate :: (Member (State (Environment address)) effects, Member (State (Exports address)) effects) => Evaluator address value effects a -> Evaluator address value effects a
|
||||||
isolate = withEnv lowerBound . withExports lowerBound
|
isolate = withEnv lowerBound . withExports lowerBound
|
||||||
|
|
||||||
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator location value effects ()
|
traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator address value effects ()
|
||||||
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
|
traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path)
|
||||||
|
|
||||||
|
|
||||||
@ -233,4 +224,4 @@ instance Evaluatable s => Evaluatable (TermF s a) where
|
|||||||
--- 3. Only the last statement’s return value is returned.
|
--- 3. Only the last statement’s return value is returned.
|
||||||
instance Evaluatable [] where
|
instance Evaluatable [] where
|
||||||
-- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
|
-- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists.
|
||||||
eval = maybe (Rval <$> unit) (runApp . foldMap1 (App . subtermRef)) . nonEmpty
|
eval = maybe (pure (Rval unit)) (runApp . foldMap1 (App . subtermRef)) . nonEmpty
|
||||||
|
@ -7,31 +7,30 @@ module Data.Abstract.Exports
|
|||||||
, toEnvironment
|
, toEnvironment
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prelude hiding (null)
|
|
||||||
import Prologue hiding (null)
|
|
||||||
import Data.Abstract.Address
|
|
||||||
import Data.Abstract.Environment (Environment, unpairs)
|
import Data.Abstract.Environment (Environment, unpairs)
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import Data.Semilattice.Lower
|
import Data.Semilattice.Lower
|
||||||
|
import Prelude hiding (null)
|
||||||
|
import Prologue hiding (null)
|
||||||
|
|
||||||
-- | A map of export names to an alias & address tuple.
|
-- | A map of export names to an alias & address tuple.
|
||||||
newtype Exports location = Exports { unExports :: Map.Map Name (Name, Maybe location) }
|
newtype Exports address = Exports { unExports :: Map.Map Name (Name, Maybe address) }
|
||||||
deriving (Eq, Lower, Monoid, Ord, Semigroup)
|
deriving (Eq, Lower, Monoid, Ord, Semigroup)
|
||||||
|
|
||||||
null :: Exports location -> Bool
|
null :: Exports address -> Bool
|
||||||
null = Map.null . unExports
|
null = Map.null . unExports
|
||||||
|
|
||||||
toEnvironment :: Exports location -> Environment location
|
toEnvironment :: Exports address -> Environment address
|
||||||
toEnvironment exports = unpairs (mapMaybe (traverse (fmap Address)) (toList (unExports exports)))
|
toEnvironment exports = unpairs (mapMaybe sequenceA (toList (unExports exports)))
|
||||||
|
|
||||||
insert :: Name -> Name -> Maybe (Address location value) -> Exports location -> Exports location
|
insert :: Name -> Name -> Maybe address -> Exports address -> Exports address
|
||||||
insert name alias address = Exports . Map.insert name (alias, unAddress <$> address) . unExports
|
insert name alias address = Exports . Map.insert name (alias, address) . unExports
|
||||||
|
|
||||||
-- TODO: Should we filter for duplicates here?
|
-- TODO: Should we filter for duplicates here?
|
||||||
aliases :: Exports location -> [(Name, Name)]
|
aliases :: Exports address -> [(Name, Name)]
|
||||||
aliases = Map.toList . fmap fst . unExports
|
aliases = Map.toList . fmap fst . unExports
|
||||||
|
|
||||||
|
|
||||||
instance Show location => Show (Exports location) where
|
instance Show address => Show (Exports address) where
|
||||||
showsPrec d = showsUnaryWith showsPrec "Exports" d . Map.toList . unExports
|
showsPrec d = showsUnaryWith showsPrec "Exports" d . Map.toList . unExports
|
||||||
|
@ -1,7 +1,6 @@
|
|||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
module Data.Abstract.Heap where
|
module Data.Abstract.Heap where
|
||||||
|
|
||||||
import Data.Abstract.Address
|
|
||||||
import Data.Abstract.Live
|
import Data.Abstract.Live
|
||||||
import qualified Data.Map.Monoidal as Monoidal
|
import qualified Data.Map.Monoidal as Monoidal
|
||||||
import Data.Semigroup.Reducer
|
import Data.Semigroup.Reducer
|
||||||
@ -9,38 +8,38 @@ import Data.Semilattice.Lower
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | A map of addresses onto cells holding their values.
|
-- | A map of addresses onto cells holding their values.
|
||||||
newtype Heap location cell value = Heap { unHeap :: Monoidal.Map location (cell value) }
|
newtype Heap address cell value = Heap { unHeap :: Monoidal.Map address (cell value) }
|
||||||
deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Traversable)
|
deriving (Eq, Foldable, Functor, Lower, Monoid, Ord, Semigroup, Traversable)
|
||||||
|
|
||||||
-- | Look up the cell of values for an 'Address' in a 'Heap', if any.
|
-- | Look up the cell of values for an 'Address' in a 'Heap', if any.
|
||||||
heapLookup :: Ord location => Address location value -> Heap location cell value -> Maybe (cell value)
|
heapLookup :: Ord address => address -> Heap address cell value -> Maybe (cell value)
|
||||||
heapLookup (Address address) = Monoidal.lookup address . unHeap
|
heapLookup address = Monoidal.lookup address . unHeap
|
||||||
|
|
||||||
-- | Look up the list of values stored for a given address, if any.
|
-- | Look up the list of values stored for a given address, if any.
|
||||||
heapLookupAll :: (Ord location, Foldable cell) => Address location value -> Heap location cell value -> Maybe [value]
|
heapLookupAll :: (Ord address, Foldable cell) => address -> Heap address cell value -> Maybe [value]
|
||||||
heapLookupAll address = fmap toList . heapLookup address
|
heapLookupAll address = fmap toList . heapLookup address
|
||||||
|
|
||||||
-- | Append a value onto the cell for a given address, inserting a new cell if none existed.
|
-- | Append a value onto the cell for a given address, inserting a new cell if none existed.
|
||||||
heapInsert :: (Ord location, Reducer value (cell value)) => Address location value -> value -> Heap location cell value -> Heap location cell value
|
heapInsert :: (Ord address, Reducer value (cell value)) => address -> value -> Heap address cell value -> Heap address cell value
|
||||||
heapInsert address value = flip snoc (address, value)
|
heapInsert address value = flip snoc (address, value)
|
||||||
|
|
||||||
-- | Manually insert a cell into the heap at a given address.
|
-- | Manually insert a cell into the heap at a given address.
|
||||||
heapInit :: Ord location => Address location value -> cell value -> Heap location cell value -> Heap location cell value
|
heapInit :: Ord address => address -> cell value -> Heap address cell value -> Heap address cell value
|
||||||
heapInit (Address address) cell (Heap h) = Heap (Monoidal.insert address cell h)
|
heapInit address cell (Heap h) = Heap (Monoidal.insert address cell h)
|
||||||
|
|
||||||
-- | The number of addresses extant in a 'Heap'.
|
-- | The number of addresses extant in a 'Heap'.
|
||||||
heapSize :: Heap location cell value -> Int
|
heapSize :: Heap address cell value -> Int
|
||||||
heapSize = Monoidal.size . unHeap
|
heapSize = Monoidal.size . unHeap
|
||||||
|
|
||||||
-- | Restrict a 'Heap' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest).
|
-- | Restrict a 'Heap' to only those addresses in the given 'Live' set (in essence garbage collecting the rest).
|
||||||
heapRestrict :: Ord location => Heap location cell value -> Live location value -> Heap location cell value
|
heapRestrict :: Ord address => Heap address cell value -> Live address -> Heap address cell value
|
||||||
heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m)
|
heapRestrict (Heap m) roots = Heap (Monoidal.filterWithKey (\ address _ -> address `liveMember` roots) m)
|
||||||
|
|
||||||
|
|
||||||
instance (Ord location, Reducer value (cell value)) => Reducer (Address location value, value) (Heap location cell value) where
|
instance (Ord address, Reducer value (cell value)) => Reducer (address, value) (Heap address cell value) where
|
||||||
unit = Heap . unit . first unAddress
|
unit = Heap . unit
|
||||||
cons (Address key, a) (Heap heap) = Heap (cons (key, a) heap)
|
cons (addr, a) (Heap heap) = Heap (cons (addr, a) heap)
|
||||||
snoc (Heap heap) (Address key, a) = Heap (snoc heap (key, a))
|
snoc (Heap heap) (addr, a) = Heap (snoc heap (addr, a))
|
||||||
|
|
||||||
instance (Show location, Show (cell value)) => Show (Heap location cell value) where
|
instance (Show address, Show (cell value)) => Show (Heap address cell value) where
|
||||||
showsPrec d = showsUnaryWith showsPrec "Heap" d . Monoidal.pairs . unHeap
|
showsPrec d = showsUnaryWith showsPrec "Heap" d . Monoidal.pairs . unHeap
|
||||||
|
@ -1,42 +1,41 @@
|
|||||||
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
|
{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-}
|
||||||
module Data.Abstract.Live where
|
module Data.Abstract.Live where
|
||||||
|
|
||||||
import Data.Abstract.Address
|
|
||||||
import Data.Semilattice.Lower
|
import Data.Semilattice.Lower
|
||||||
import Data.Set as Set
|
import Data.Set as Set
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | A set of live addresses (whether roots or reachable).
|
-- | A set of live addresses (whether roots or reachable).
|
||||||
newtype Live location value = Live { unLive :: Set location }
|
newtype Live address = Live { unLive :: Set address }
|
||||||
deriving (Eq, Lower, Monoid, Ord, Semigroup)
|
deriving (Eq, Lower, Monoid, Ord, Semigroup)
|
||||||
|
|
||||||
fromAddresses :: (Foldable t, Ord location) => t (Address location value) -> Live location value
|
fromAddresses :: (Foldable t, Ord address) => t address -> Live address
|
||||||
fromAddresses = Prologue.foldr liveInsert lowerBound
|
fromAddresses = Prologue.foldr liveInsert lowerBound
|
||||||
|
|
||||||
-- | Construct a 'Live' set containing only the given address.
|
-- | Construct a 'Live' set containing only the given address.
|
||||||
liveSingleton :: Address location value -> Live location value
|
liveSingleton :: address -> Live address
|
||||||
liveSingleton = Live . Set.singleton . unAddress
|
liveSingleton = Live . Set.singleton
|
||||||
|
|
||||||
-- | Insert an address into a 'Live' set.
|
-- | Insert an address into a 'Live' set.
|
||||||
liveInsert :: Ord location => Address location value -> Live location value -> Live location value
|
liveInsert :: Ord address => address -> Live address -> Live address
|
||||||
liveInsert addr = Live . Set.insert (unAddress addr) . unLive
|
liveInsert addr = Live . Set.insert addr . unLive
|
||||||
|
|
||||||
-- | Delete an address from a 'Live' set, if present.
|
-- | Delete an address from a 'Live' set, if present.
|
||||||
liveDelete :: Ord location => Address location value -> Live location value -> Live location value
|
liveDelete :: Ord address => address -> Live address -> Live address
|
||||||
liveDelete addr = Live . Set.delete (unAddress addr) . unLive
|
liveDelete addr = Live . Set.delete addr . unLive
|
||||||
|
|
||||||
-- | Compute the (asymmetric) difference of two 'Live' sets, i.e. delete every element of the second set from the first set.
|
-- | Compute the (asymmetric) difference of two 'Live' sets, i.e. delete every element of the second set from the first set.
|
||||||
liveDifference :: Ord location => Live location value -> Live location value -> Live location value
|
liveDifference :: Ord address => Live address -> Live address -> Live address
|
||||||
liveDifference = fmap Live . (Set.difference `on` unLive)
|
liveDifference = fmap Live . (Set.difference `on` unLive)
|
||||||
|
|
||||||
-- | Test whether an 'Address' is in a 'Live' set.
|
-- | Test whether an address is in a 'Live' set.
|
||||||
liveMember :: Ord location => Address location value -> Live location value -> Bool
|
liveMember :: Ord address => address -> Live address -> Bool
|
||||||
liveMember addr = Set.member (unAddress addr) . unLive
|
liveMember addr = Set.member addr . unLive
|
||||||
|
|
||||||
-- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty.
|
-- | Decompose a 'Live' set into a pair of one member address and the remaining set, or 'Nothing' if empty.
|
||||||
liveSplit :: Live location value -> Maybe (Address location value, Live location value)
|
liveSplit :: Live address -> Maybe (address, Live address)
|
||||||
liveSplit = fmap (bimap Address Live) . Set.minView . unLive
|
liveSplit = fmap (fmap Live) . Set.minView . unLive
|
||||||
|
|
||||||
|
|
||||||
instance Show location => Show (Live location value) where
|
instance Show address => Show (Live address) where
|
||||||
showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive
|
showsPrec d = showsUnaryWith showsPrec "Live" d . Set.toList . unLive
|
||||||
|
@ -94,33 +94,45 @@ unify t1 t2
|
|||||||
| t1 == t2 = pure t2
|
| t1 == t2 = pure t2
|
||||||
| otherwise = throwResumable (UnificationError t1 t2)
|
| otherwise = throwResumable (UnificationError t1 t2)
|
||||||
|
|
||||||
instance Ord location => ValueRoots location Type where
|
instance Ord address => ValueRoots address Type where
|
||||||
valueRoots _ = mempty
|
valueRoots _ = mempty
|
||||||
|
|
||||||
|
|
||||||
instance AbstractHole Type where
|
instance AbstractHole Type where
|
||||||
hole = Hole
|
hole = Hole
|
||||||
|
|
||||||
instance ( Members '[ Allocator location Type
|
instance AbstractIntro Type where
|
||||||
, Fresh
|
unit = Unit
|
||||||
, NonDet
|
integer _ = Int
|
||||||
, Reader (Environment location)
|
boolean _ = Bool
|
||||||
, Resumable TypeError
|
string _ = String
|
||||||
, Return Type
|
float _ = Float
|
||||||
, State (Environment location)
|
symbol _ = Symbol
|
||||||
, State (Heap location (Cell location) Type)
|
rational _ = Rational
|
||||||
] effects
|
multiple = zeroOrMoreProduct
|
||||||
, Ord location
|
hash = Hash
|
||||||
, Reducer Type (Cell location Type)
|
kvPair k v = k :* v
|
||||||
|
|
||||||
|
null = Null
|
||||||
|
|
||||||
|
|
||||||
|
instance ( Member (Allocator address Type) effects
|
||||||
|
, Member Fresh effects
|
||||||
|
, Member (Resumable TypeError) effects
|
||||||
|
, Member (Return Type) effects
|
||||||
|
, Member (State (Environment address)) effects
|
||||||
|
, Member (State (Heap address (Cell address) Type)) effects
|
||||||
|
, Ord address
|
||||||
|
, Reducer Type (Cell address Type)
|
||||||
)
|
)
|
||||||
=> AbstractFunction location Type effects where
|
=> AbstractFunction address Type effects where
|
||||||
closure names _ body = do
|
closure names _ body = do
|
||||||
(env, tvars) <- foldr (\ name rest -> do
|
(env, tvars) <- foldr (\ name rest -> do
|
||||||
a <- alloc name
|
a <- alloc name
|
||||||
tvar <- Var <$> fresh
|
tvar <- Var <$> fresh
|
||||||
assign a tvar
|
assign a tvar
|
||||||
bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names
|
bimap (Env.insert name a) (tvar :) <$> rest) (pure (emptyEnv, [])) names
|
||||||
(zeroOrMoreProduct tvars :->) <$> localEnv (mergeEnvs env) (body `catchReturn` \ (Return value) -> pure value)
|
(zeroOrMoreProduct tvars :->) <$> locally (bindAll env *> body `catchReturn` \ (Return value) -> pure value)
|
||||||
|
|
||||||
call op params = do
|
call op params = do
|
||||||
tvar <- fresh
|
tvar <- fresh
|
||||||
@ -133,34 +145,20 @@ instance ( Members '[ Allocator location Type
|
|||||||
|
|
||||||
|
|
||||||
-- | Discard the value arguments (if any), constructing a 'Type' instead.
|
-- | Discard the value arguments (if any), constructing a 'Type' instead.
|
||||||
instance ( Members '[ Allocator location Type
|
instance ( Member (Allocator address Type) effects
|
||||||
, Fresh
|
, Member Fresh effects
|
||||||
, NonDet
|
, Member NonDet effects
|
||||||
, Reader (Environment location)
|
, Member (Resumable TypeError) effects
|
||||||
, Resumable TypeError
|
, Member (Return Type) effects
|
||||||
, Return Type
|
, Member (State (Environment address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Heap address (Cell address) Type)) effects
|
||||||
, State (Heap location (Cell location) Type)
|
, Ord address
|
||||||
] effects
|
, Reducer Type (Cell address Type)
|
||||||
, Ord location
|
|
||||||
, Reducer Type (Cell location Type)
|
|
||||||
)
|
)
|
||||||
=> AbstractValue location Type effects where
|
=> AbstractValue address Type effects where
|
||||||
unit = pure Unit
|
|
||||||
integer _ = pure Int
|
|
||||||
boolean _ = pure Bool
|
|
||||||
string _ = pure String
|
|
||||||
float _ = pure Float
|
|
||||||
symbol _ = pure Symbol
|
|
||||||
rational _ = pure Rational
|
|
||||||
multiple = pure . zeroOrMoreProduct
|
|
||||||
array fields = do
|
array fields = do
|
||||||
var <- fresh
|
var <- fresh
|
||||||
Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fields
|
Array <$> foldr (\ t1 -> (unify t1 =<<)) (pure (Var var)) fields
|
||||||
hash = pure . Hash
|
|
||||||
kvPair k v = pure (k :* v)
|
|
||||||
|
|
||||||
null = pure Null
|
|
||||||
|
|
||||||
klass _ _ _ = pure Object
|
klass _ _ _ = pure Object
|
||||||
namespace _ _ = pure Unit
|
namespace _ _ = pure Unit
|
||||||
|
@ -6,6 +6,7 @@ import Data.Abstract.Environment (Environment, emptyEnv, mergeEnvs)
|
|||||||
import qualified Data.Abstract.Environment as Env
|
import qualified Data.Abstract.Environment as Env
|
||||||
import Data.Abstract.Name
|
import Data.Abstract.Name
|
||||||
import qualified Data.Abstract.Number as Number
|
import qualified Data.Abstract.Number as Number
|
||||||
|
import Data.Coerce
|
||||||
import Data.List (genericIndex, genericLength)
|
import Data.List (genericIndex, genericLength)
|
||||||
import Data.Scientific (Scientific)
|
import Data.Scientific (Scientific)
|
||||||
import Data.Scientific.Exts
|
import Data.Scientific.Exts
|
||||||
@ -13,8 +14,8 @@ import Data.Semigroup.Reducer
|
|||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
data Value location
|
data Value address body
|
||||||
= Closure PackageInfo ModuleInfo [Name] Label (Environment location)
|
= Closure PackageInfo ModuleInfo [Name] (ClosureBody address body) (Environment address)
|
||||||
| Unit
|
| Unit
|
||||||
| Boolean Bool
|
| Boolean Bool
|
||||||
| Integer (Number.Number Integer)
|
| Integer (Number.Number Integer)
|
||||||
@ -22,49 +23,60 @@ data Value location
|
|||||||
| Float (Number.Number Scientific)
|
| Float (Number.Number Scientific)
|
||||||
| String ByteString
|
| String ByteString
|
||||||
| Symbol ByteString
|
| Symbol ByteString
|
||||||
| Tuple [Value location]
|
| Tuple [Value address body]
|
||||||
| Array [Value location]
|
| Array [Value address body]
|
||||||
| Class Name (Environment location)
|
| Class Name (Environment address)
|
||||||
| Namespace Name (Environment location)
|
| Namespace Name (Environment address)
|
||||||
| KVPair (Value location) (Value location)
|
| KVPair (Value address body) (Value address body)
|
||||||
| Hash [Value location]
|
| Hash [Value address body]
|
||||||
| Null
|
| Null
|
||||||
| Hole
|
| Hole
|
||||||
deriving (Eq, Show, Ord)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
instance Ord location => ValueRoots location (Value location) where
|
data ClosureBody address body = ClosureBody { closureBodyId :: Int, closureBody :: body (Value address body) }
|
||||||
|
|
||||||
|
instance Eq (ClosureBody address body) where
|
||||||
|
(==) = (==) `on` closureBodyId
|
||||||
|
|
||||||
|
instance Ord (ClosureBody address body) where
|
||||||
|
compare = compare `on` closureBodyId
|
||||||
|
|
||||||
|
instance Show (ClosureBody address body) where
|
||||||
|
showsPrec d (ClosureBody i _) = showsBinaryWith showsPrec (const showChar) "ClosureBody" d i '_'
|
||||||
|
|
||||||
|
|
||||||
|
instance Ord address => ValueRoots address (Value address body) where
|
||||||
valueRoots v
|
valueRoots v
|
||||||
| Closure _ _ _ _ env <- v = Env.addresses env
|
| Closure _ _ _ _ env <- v = Env.addresses env
|
||||||
| otherwise = mempty
|
| otherwise = mempty
|
||||||
|
|
||||||
|
|
||||||
instance AbstractHole (Value location) where
|
instance AbstractHole (Value address body) where
|
||||||
hole = Hole
|
hole = Hole
|
||||||
|
|
||||||
instance ( Members '[ Allocator location (Value location)
|
instance ( Coercible body (Eff effects)
|
||||||
, Reader (Environment location)
|
, Member (Allocator address (Value address body)) effects
|
||||||
, Reader ModuleInfo
|
, Member Fresh effects
|
||||||
, Reader PackageInfo
|
, Member (Reader ModuleInfo) effects
|
||||||
, Resumable (ValueError location)
|
, Member (Reader PackageInfo) effects
|
||||||
, Return (Value location)
|
, Member (Resumable (ValueError address body)) effects
|
||||||
, State (Environment location)
|
, Member (Return (Value address body)) effects
|
||||||
, State (Heap location (Cell location) (Value location))
|
, Member (State (Environment address)) effects
|
||||||
] effects
|
, Member (State (Heap address (Cell address) (Value address body))) effects
|
||||||
, Ord location
|
, Ord address
|
||||||
, Reducer (Value location) (Cell location (Value location))
|
, Reducer (Value address body) (Cell address (Value address body))
|
||||||
, Show location
|
, Show address
|
||||||
)
|
)
|
||||||
=> AbstractFunction location (Value location) (Goto effects (Value location) ': effects) where
|
=> AbstractFunction address (Value address body) effects where
|
||||||
closure parameters freeVariables body = do
|
closure parameters freeVariables body = do
|
||||||
packageInfo <- currentPackage
|
packageInfo <- currentPackage
|
||||||
moduleInfo <- currentModule
|
moduleInfo <- currentModule
|
||||||
l <- label body
|
i <- fresh
|
||||||
Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv
|
Closure packageInfo moduleInfo parameters (ClosureBody i (coerce (lowerEff body))) . Env.intersect (foldr Set.delete freeVariables parameters) <$> getEnv
|
||||||
|
|
||||||
call op params = do
|
call op params = do
|
||||||
case op of
|
case op of
|
||||||
Closure packageInfo moduleInfo names label env -> do
|
Closure packageInfo moduleInfo names (ClosureBody _ body) env -> do
|
||||||
body <- goto label
|
|
||||||
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
|
-- Evaluate the bindings and body with the closure’s package/module info in scope in order to
|
||||||
-- charge them to the closure's origin.
|
-- charge them to the closure's origin.
|
||||||
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
|
withCurrentPackage packageInfo . withCurrentModule moduleInfo $ do
|
||||||
@ -73,46 +85,49 @@ instance ( Members '[ Allocator location (Value location)
|
|||||||
a <- alloc name
|
a <- alloc name
|
||||||
assign a v
|
assign a v
|
||||||
Env.insert name a <$> rest) (pure env) (zip names params)
|
Env.insert name a <$> rest) (pure env) (zip names params)
|
||||||
localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value)
|
locally (bindAll bindings *> raiseEff (coerce body) `catchReturn` \ (Return value) -> pure value)
|
||||||
_ -> throwValueError (CallError op)
|
_ -> throwValueError (CallError op)
|
||||||
|
|
||||||
|
|
||||||
|
instance Show address => AbstractIntro (Value address body) where
|
||||||
|
unit = Unit
|
||||||
|
integer = Integer . Number.Integer
|
||||||
|
boolean = Boolean
|
||||||
|
string = String
|
||||||
|
float = Float . Number.Decimal
|
||||||
|
symbol = Symbol
|
||||||
|
rational = Rational . Number.Ratio
|
||||||
|
|
||||||
|
multiple = Tuple
|
||||||
|
|
||||||
|
kvPair = KVPair
|
||||||
|
hash = Hash . map (uncurry KVPair)
|
||||||
|
|
||||||
|
null = Null
|
||||||
|
|
||||||
|
|
||||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||||
instance ( Members '[ Allocator location (Value location)
|
instance ( Coercible body (Eff effects)
|
||||||
, LoopControl (Value location)
|
, Member (Allocator address (Value address body)) effects
|
||||||
, Reader (Environment location)
|
, Member Fresh effects
|
||||||
, Reader ModuleInfo
|
, Member (LoopControl (Value address body)) effects
|
||||||
, Reader PackageInfo
|
, Member (Reader (Environment address)) effects
|
||||||
, Resumable (ValueError location)
|
, Member (Reader ModuleInfo) effects
|
||||||
, Return (Value location)
|
, Member (Reader PackageInfo) effects
|
||||||
, State (Environment location)
|
, Member (Resumable (ValueError address body)) effects
|
||||||
, State (Heap location (Cell location) (Value location))
|
, Member (Return (Value address body)) effects
|
||||||
] effects
|
, Member (State (Environment address)) effects
|
||||||
, Ord location
|
, Member (State (Heap address (Cell address) (Value address body))) effects
|
||||||
, Reducer (Value location) (Cell location (Value location))
|
, Ord address
|
||||||
, Show location
|
, Reducer (Value address body) (Cell address (Value address body))
|
||||||
|
, Show address
|
||||||
)
|
)
|
||||||
=> AbstractValue location (Value location) (Goto effects (Value location) ': effects) where
|
=> AbstractValue address (Value address body) effects where
|
||||||
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 . Tuple
|
|
||||||
array = pure . Array
|
|
||||||
|
|
||||||
kvPair k = pure . KVPair k
|
|
||||||
|
|
||||||
null = pure Null
|
|
||||||
|
|
||||||
asPair val
|
asPair val
|
||||||
| KVPair k v <- val = pure (k, v)
|
| KVPair k v <- val = pure (k, v)
|
||||||
| otherwise = throwValueError $ KeyValueError val
|
| otherwise = throwValueError $ KeyValueError val
|
||||||
|
|
||||||
hash = pure . Hash . map (uncurry KVPair)
|
array = pure . Array
|
||||||
|
|
||||||
klass n [] env = pure $ Class n env
|
klass n [] env = pure $ Class n env
|
||||||
klass n supers env = do
|
klass n supers env = do
|
||||||
@ -150,9 +165,9 @@ instance ( Members '[ Allocator location (Value location)
|
|||||||
| otherwise = throwValueError (IndexError arr idx)
|
| otherwise = throwValueError (IndexError arr idx)
|
||||||
|
|
||||||
liftNumeric f arg
|
liftNumeric f arg
|
||||||
| Integer (Number.Integer i) <- arg = integer $ f i
|
| Integer (Number.Integer i) <- arg = pure . integer $ f i
|
||||||
| Float (Number.Decimal d) <- arg = float $ f d
|
| Float (Number.Decimal d) <- arg = pure . float $ f d
|
||||||
| Rational (Number.Ratio r) <- arg = rational $ f r
|
| Rational (Number.Ratio r) <- arg = pure . rational $ f r
|
||||||
| otherwise = throwValueError (NumericError arg)
|
| otherwise = throwValueError (NumericError arg)
|
||||||
|
|
||||||
liftNumeric2 f left right
|
liftNumeric2 f left right
|
||||||
@ -170,11 +185,11 @@ instance ( Members '[ Allocator location (Value location)
|
|||||||
tentative x i j = attemptUnsafeArithmetic (x i j)
|
tentative x i j = attemptUnsafeArithmetic (x i j)
|
||||||
|
|
||||||
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
|
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
|
||||||
specialize :: (AbstractValue location (Value location) effects, Member (Resumable (ValueError location)) effects) => Either ArithException Number.SomeNumber -> Evaluator location (Value location) effects (Value location)
|
specialize :: (AbstractValue address (Value address body) effects, Member (Resumable (ValueError address body)) effects) => Either ArithException Number.SomeNumber -> Evaluator address (Value address body) effects (Value address body)
|
||||||
specialize (Left exc) = throwValueError (ArithmeticError exc)
|
specialize (Left exc) = throwValueError (ArithmeticError exc)
|
||||||
specialize (Right (Number.SomeNumber (Number.Integer i))) = integer i
|
specialize (Right (Number.SomeNumber (Number.Integer i))) = pure $ integer i
|
||||||
specialize (Right (Number.SomeNumber (Number.Ratio r))) = rational r
|
specialize (Right (Number.SomeNumber (Number.Ratio r))) = pure $ rational r
|
||||||
specialize (Right (Number.SomeNumber (Number.Decimal d))) = float d
|
specialize (Right (Number.SomeNumber (Number.Decimal d))) = pure $ float d
|
||||||
pair = (left, right)
|
pair = (left, right)
|
||||||
|
|
||||||
liftComparison comparator left right
|
liftComparison comparator left right
|
||||||
@ -184,15 +199,15 @@ instance ( Members '[ Allocator location (Value location)
|
|||||||
| (Float (Number.Decimal i), Float (Number.Decimal j)) <- pair = go i j
|
| (Float (Number.Decimal i), Float (Number.Decimal j)) <- pair = go i j
|
||||||
| (String i, String j) <- pair = go i j
|
| (String i, String j) <- pair = go i j
|
||||||
| (Boolean i, Boolean j) <- pair = go i j
|
| (Boolean i, Boolean j) <- pair = go i j
|
||||||
| (Unit, Unit) <- pair = boolean True
|
| (Unit, Unit) <- pair = pure $ boolean True
|
||||||
| otherwise = throwValueError (ComparisonError left right)
|
| otherwise = throwValueError (ComparisonError left right)
|
||||||
where
|
where
|
||||||
-- Explicit type signature is necessary here because we're passing all sorts of things
|
-- Explicit type signature is necessary here because we're passing all sorts of things
|
||||||
-- to these comparison functions.
|
-- to these comparison functions.
|
||||||
go :: (AbstractValue location (Value location) effects, Ord a) => a -> a -> Evaluator location (Value location) effects (Value location)
|
go :: (AbstractValue address (Value address body) effects, Ord a) => a -> a -> Evaluator address (Value address body) effects (Value address body)
|
||||||
go l r = case comparator of
|
go l r = case comparator of
|
||||||
Concrete f -> boolean (f l r)
|
Concrete f -> pure $ boolean (f l r)
|
||||||
Generalized -> integer (orderingToInt (compare l r))
|
Generalized -> pure $ integer (orderingToInt (compare l r))
|
||||||
|
|
||||||
-- Map from [LT, EQ, GT] to [-1, 0, 1]
|
-- Map from [LT, EQ, GT] to [-1, 0, 1]
|
||||||
orderingToInt :: Ordering -> Prelude.Integer
|
orderingToInt :: Ordering -> Prelude.Integer
|
||||||
@ -202,11 +217,11 @@ instance ( Members '[ Allocator location (Value location)
|
|||||||
|
|
||||||
|
|
||||||
liftBitwise operator target
|
liftBitwise operator target
|
||||||
| Integer (Number.Integer i) <- target = integer $ operator i
|
| Integer (Number.Integer i) <- target = pure . integer $ operator i
|
||||||
| otherwise = throwValueError (BitwiseError target)
|
| otherwise = throwValueError (BitwiseError target)
|
||||||
|
|
||||||
liftBitwise2 operator left right
|
liftBitwise2 operator left right
|
||||||
| (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = integer $ operator i j
|
| (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = pure . integer $ operator i j
|
||||||
| otherwise = throwValueError (Bitwise2Error left right)
|
| otherwise = throwValueError (Bitwise2Error left right)
|
||||||
where pair = (left, right)
|
where pair = (left, right)
|
||||||
|
|
||||||
@ -217,25 +232,25 @@ instance ( Members '[ Allocator location (Value location)
|
|||||||
|
|
||||||
|
|
||||||
-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
|
-- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance.
|
||||||
data ValueError location resume where
|
data ValueError address body resume where
|
||||||
StringError :: Value location -> ValueError location ByteString
|
StringError :: Value address body -> ValueError address body ByteString
|
||||||
BoolError :: Value location -> ValueError location Bool
|
BoolError :: Value address body -> ValueError address body Bool
|
||||||
IndexError :: Value location -> Value location -> ValueError location (Value location)
|
IndexError :: Value address body -> Value address body -> ValueError address body (Value address body)
|
||||||
NamespaceError :: Prelude.String -> ValueError location (Environment location)
|
NamespaceError :: Prelude.String -> ValueError address body (Environment address)
|
||||||
CallError :: Value location -> ValueError location (Value location)
|
CallError :: Value address body -> ValueError address body (Value address body)
|
||||||
NumericError :: Value location -> ValueError location (Value location)
|
NumericError :: Value address body -> ValueError address body (Value address body)
|
||||||
Numeric2Error :: Value location -> Value location -> ValueError location (Value location)
|
Numeric2Error :: Value address body -> Value address body -> ValueError address body (Value address body)
|
||||||
ComparisonError :: Value location -> Value location -> ValueError location (Value location)
|
ComparisonError :: Value address body -> Value address body -> ValueError address body (Value address body)
|
||||||
BitwiseError :: Value location -> ValueError location (Value location)
|
BitwiseError :: Value address body -> ValueError address body (Value address body)
|
||||||
Bitwise2Error :: Value location -> Value location -> ValueError location (Value location)
|
Bitwise2Error :: Value address body -> Value address body -> ValueError address body (Value address body)
|
||||||
KeyValueError :: Value location -> ValueError location (Value location, Value location)
|
KeyValueError :: Value address body -> ValueError address body (Value address body, Value address body)
|
||||||
-- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
|
-- Indicates that we encountered an arithmetic exception inside Haskell-native number crunching.
|
||||||
ArithmeticError :: ArithException -> ValueError location (Value location)
|
ArithmeticError :: ArithException -> ValueError address body (Value address body)
|
||||||
-- Out-of-bounds error
|
-- Out-of-bounds error
|
||||||
BoundsError :: [Value location] -> Prelude.Integer -> ValueError location (Value location)
|
BoundsError :: [Value address body] -> Prelude.Integer -> ValueError address body (Value address body)
|
||||||
|
|
||||||
|
|
||||||
instance Eq location => Eq1 (ValueError location) where
|
instance Eq address => Eq1 (ValueError address body) where
|
||||||
liftEq _ (StringError a) (StringError b) = a == b
|
liftEq _ (StringError a) (StringError b) = a == b
|
||||||
liftEq _ (NamespaceError a) (NamespaceError b) = a == b
|
liftEq _ (NamespaceError a) (NamespaceError b) = a == b
|
||||||
liftEq _ (CallError a) (CallError b) = a == b
|
liftEq _ (CallError a) (CallError b) = a == b
|
||||||
@ -249,15 +264,15 @@ instance Eq location => Eq1 (ValueError location) where
|
|||||||
liftEq _ (BoundsError a b) (BoundsError c d) = (a == c) && (b == d)
|
liftEq _ (BoundsError a b) (BoundsError c d) = (a == c) && (b == d)
|
||||||
liftEq _ _ _ = False
|
liftEq _ _ _ = False
|
||||||
|
|
||||||
deriving instance Show location => Show (ValueError location resume)
|
deriving instance Show address => Show (ValueError address body resume)
|
||||||
instance Show location => Show1 (ValueError location) where
|
instance Show address => Show1 (ValueError address body) where
|
||||||
liftShowsPrec _ _ = showsPrec
|
liftShowsPrec _ _ = showsPrec
|
||||||
|
|
||||||
throwValueError :: Member (Resumable (ValueError location)) effects => ValueError location resume -> Evaluator location (Value location) effects resume
|
throwValueError :: Member (Resumable (ValueError address body)) effects => ValueError address body resume -> Evaluator address (Value address body) effects resume
|
||||||
throwValueError = throwResumable
|
throwValueError = throwResumable
|
||||||
|
|
||||||
runValueError :: Effectful (m location (Value location)) => m location (Value location) (Resumable (ValueError location) ': effects) a -> m location (Value location) effects (Either (SomeExc (ValueError location)) a)
|
runValueError :: Effectful (m address (Value address body)) => m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects (Either (SomeExc (ValueError address body)) a)
|
||||||
runValueError = runResumable
|
runValueError = runResumable
|
||||||
|
|
||||||
runValueErrorWith :: Effectful (m location (Value location)) => (forall resume . ValueError location resume -> m location (Value location) effects resume) -> m location (Value location) (Resumable (ValueError location) ': effects) a -> m location (Value location) effects a
|
runValueErrorWith :: Effectful (m address (Value address body)) => (forall resume . ValueError address body resume -> m address (Value address body) effects resume) -> m address (Value address body) (Resumable (ValueError address body) ': effects) a -> m address (Value address body) effects a
|
||||||
runValueErrorWith = runResumableWith
|
runValueErrorWith = runResumableWith
|
||||||
|
@ -1,78 +0,0 @@
|
|||||||
{-# LANGUAGE DataKinds, DefaultSignatures, TypeOperators, UndecidableInstances #-}
|
|
||||||
module Data.Align.Generic where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad
|
|
||||||
import Data.Functor (($>))
|
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import Data.Sum
|
|
||||||
import Data.These
|
|
||||||
import GHC.Generics
|
|
||||||
|
|
||||||
-- | Functors which can be aligned (structure-unioning-ly zipped). The default implementation will operate generically over the constructors in the aligning type.
|
|
||||||
class GAlign f where
|
|
||||||
-- | Perform generic alignment of values of some functor, applying the given function to alignments of elements.
|
|
||||||
galignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
|
|
||||||
default galignWith :: (Alternative g, Generic1 f, GAlign (Rep1 f)) => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
|
|
||||||
galignWith f a b = to1 <$> galignWith f (from1 a) (from1 b)
|
|
||||||
|
|
||||||
galign :: (Alternative g, GAlign f) => f a1 -> f a2 -> g (f (These a1 a2))
|
|
||||||
galign = galignWith pure
|
|
||||||
|
|
||||||
-- 'Data.Align.Align' instances
|
|
||||||
|
|
||||||
instance GAlign Maybe where
|
|
||||||
galignWith f (Just a1) (Just a2) = Just <$> f (These a1 a2)
|
|
||||||
galignWith f (Just a1) Nothing = Just <$> f (This a1)
|
|
||||||
galignWith f Nothing (Just a2) = Just <$> f (That a2)
|
|
||||||
galignWith _ Nothing Nothing = pure Nothing
|
|
||||||
|
|
||||||
instance GAlign [] where
|
|
||||||
galignWith f (a1:as1) (a2:as2) = (:) <$> f (These a1 a2) <*> galignWith f as1 as2
|
|
||||||
galignWith f [] as2 = traverse (f . That) as2
|
|
||||||
galignWith f as1 [] = traverse (f . This) as1
|
|
||||||
|
|
||||||
instance GAlign NonEmpty where
|
|
||||||
galignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> galignWith f as1 as2
|
|
||||||
|
|
||||||
instance Apply GAlign fs => GAlign (Sum fs) where
|
|
||||||
galignWith f = (fromMaybe empty .) . apply2' @GAlign (\ inj -> (fmap inj .) . galignWith f)
|
|
||||||
|
|
||||||
|
|
||||||
-- Generics
|
|
||||||
|
|
||||||
-- | 'GAlign' over unit constructors.
|
|
||||||
instance GAlign U1 where
|
|
||||||
galignWith _ _ _ = pure U1
|
|
||||||
|
|
||||||
-- | 'GAlign' over parameters.
|
|
||||||
instance GAlign Par1 where
|
|
||||||
galignWith f (Par1 a) (Par1 b) = Par1 <$> f (These a b)
|
|
||||||
|
|
||||||
-- | 'GAlign' over non-parameter fields. Only equal values are aligned.
|
|
||||||
instance Eq c => GAlign (K1 i c) where
|
|
||||||
galignWith _ (K1 a) (K1 b) = guard (a == b) $> K1 b
|
|
||||||
|
|
||||||
-- | 'GAlign' over applications over parameters.
|
|
||||||
instance GAlign f => GAlign (Rec1 f) where
|
|
||||||
galignWith f (Rec1 a) (Rec1 b) = Rec1 <$> galignWith f a b
|
|
||||||
|
|
||||||
-- | 'GAlign' over metainformation (constructor names, etc).
|
|
||||||
instance GAlign f => GAlign (M1 i c f) where
|
|
||||||
galignWith f (M1 a) (M1 b) = M1 <$> galignWith f a b
|
|
||||||
|
|
||||||
-- | 'GAlign' over sums. Returns 'Nothing' for disjoint constructors.
|
|
||||||
instance (GAlign f, GAlign g) => GAlign (f :+: g) where
|
|
||||||
galignWith f a b = case (a, b) of
|
|
||||||
(L1 a, L1 b) -> L1 <$> galignWith f a b
|
|
||||||
(R1 a, R1 b) -> R1 <$> galignWith f a b
|
|
||||||
_ -> empty
|
|
||||||
|
|
||||||
-- | 'GAlign' over products.
|
|
||||||
instance (GAlign f, GAlign g) => GAlign (f :*: g) where
|
|
||||||
galignWith f (a1 :*: b1) (a2 :*: b2) = (:*:) <$> galignWith f a1 a2 <*> galignWith f b1 b2
|
|
||||||
|
|
||||||
-- | 'GAlign' over type compositions.
|
|
||||||
instance (Traversable f, Applicative f, GAlign g) => GAlign (f :.: g) where
|
|
||||||
galignWith f (Comp1 a) (Comp1 b) = Comp1 <$> sequenceA (galignWith f <$> a <*> b)
|
|
@ -89,13 +89,13 @@ diffPatches = para $ \ diff -> case diff of
|
|||||||
|
|
||||||
|
|
||||||
-- | Recover the before state of a diff.
|
-- | Recover the before state of a diff.
|
||||||
beforeTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann1)
|
beforeTerm :: (Foldable syntax, Mergeable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann1)
|
||||||
beforeTerm = cata $ \ diff -> case diff of
|
beforeTerm = cata $ \ diff -> case diff of
|
||||||
Patch patch -> (before patch >>= \ (In a l) -> termIn a <$> sequenceAlt l) <|> (after patch >>= asum)
|
Patch patch -> (before patch >>= \ (In a l) -> termIn a <$> sequenceAlt l) <|> (after patch >>= asum)
|
||||||
Merge (In (a, _) l) -> termIn a <$> sequenceAlt l
|
Merge (In (a, _) l) -> termIn a <$> sequenceAlt l
|
||||||
|
|
||||||
-- | Recover the after state of a diff.
|
-- | Recover the after state of a diff.
|
||||||
afterTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann2)
|
afterTerm :: (Foldable syntax, Mergeable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann2)
|
||||||
afterTerm = cata $ \ diff -> case diff of
|
afterTerm = cata $ \ diff -> case diff of
|
||||||
Patch patch -> (after patch >>= \ (In b r) -> termIn b <$> sequenceAlt r) <|> (before patch >>= asum)
|
Patch patch -> (after patch >>= \ (In b r) -> termIn b <$> sequenceAlt r) <|> (before patch >>= asum)
|
||||||
Merge (In (_, b) r) -> termIn b <$> sequenceAlt r
|
Merge (In (_, b) r) -> termIn b <$> sequenceAlt r
|
||||||
|
@ -13,71 +13,62 @@ import GHC.Generics
|
|||||||
--
|
--
|
||||||
-- This is a kind of distributive law which produces (at least) the union of the two functors’ shapes; i.e. unlike 'Traversable', an 'empty' value in the inner functor does not produce an 'empty' result, and unlike 'Crosswalk', an 'empty' value in the outer functor does not produce an 'empty' result.
|
-- This is a kind of distributive law which produces (at least) the union of the two functors’ shapes; i.e. unlike 'Traversable', an 'empty' value in the inner functor does not produce an 'empty' result, and unlike 'Crosswalk', an 'empty' value in the outer functor does not produce an 'empty' result.
|
||||||
--
|
--
|
||||||
-- For example, we can use 'merge' to select one side or the other of a diff node in 'Syntax', while correctly handling the fact that some patches don’t have any content for that side:
|
-- For example, 'Data.Diff' uses 'sequenceAlt' to select one side or the other of a diff node, while correctly handling the fact that some patches don’t have any content for that side.
|
||||||
--
|
|
||||||
-- @
|
|
||||||
-- let before = iter (\ (a :< s) -> cofree . (fst a :<) <$> sequenceAlt syntax) . fmap (maybeFst . unPatch)
|
|
||||||
-- @
|
|
||||||
class Functor t => Mergeable t where
|
class Functor t => Mergeable t where
|
||||||
-- | Merge a functor by mapping its elements into an 'Alternative' functor, combining them, and pushing the 'Mergeable' functor inside.
|
-- | Sequence a 'Mergeable' functor by merging the 'Alternative' values.
|
||||||
merge :: Alternative f => (a -> f b) -> t a -> f (t b)
|
|
||||||
default merge :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => (a -> f b) -> t a -> f (t b)
|
|
||||||
merge = genericMerge
|
|
||||||
|
|
||||||
-- | Sequnce a 'Mergeable' functor by 'merge'ing the 'Alternative' values.
|
|
||||||
sequenceAlt :: Alternative f => t (f a) -> f (t a)
|
sequenceAlt :: Alternative f => t (f a) -> f (t a)
|
||||||
sequenceAlt = merge id
|
default sequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a)
|
||||||
|
sequenceAlt = genericSequenceAlt
|
||||||
|
|
||||||
|
|
||||||
-- Instances
|
-- Instances
|
||||||
|
|
||||||
instance Mergeable [] where
|
instance Mergeable [] where
|
||||||
merge f (x:xs) = ((:) <$> f x <|> pure id) <*> merge f xs
|
sequenceAlt = foldr (\ x -> (((:) <$> x <|> pure id) <*>)) (pure [])
|
||||||
merge _ [] = pure []
|
|
||||||
|
|
||||||
instance Mergeable NonEmpty where
|
instance Mergeable NonEmpty where
|
||||||
merge f (x:|[]) = (:|) <$> f x <*> pure []
|
sequenceAlt (x :|[]) = (:|) <$> x <*> pure []
|
||||||
merge f (x1:|x2:xs) = (:|) <$> f x1 <*> merge f (x2 : xs) <|> merge f (x2:|xs)
|
sequenceAlt (x1:|x2:xs) = (:|) <$> x1 <*> sequenceAlt (x2 : xs) <|> sequenceAlt (x2:|xs)
|
||||||
|
|
||||||
instance Mergeable Maybe where
|
instance Mergeable Maybe where
|
||||||
merge f (Just a) = Just <$> f a
|
sequenceAlt = maybe (pure empty) (fmap Just)
|
||||||
merge _ Nothing = pure empty
|
|
||||||
|
|
||||||
instance Mergeable Identity where merge f = fmap Identity . f . runIdentity
|
instance Mergeable Identity where
|
||||||
|
sequenceAlt = fmap Identity . runIdentity
|
||||||
|
|
||||||
instance (Apply Functor fs, Apply Mergeable fs) => Mergeable (Sum fs) where
|
instance (Apply Functor fs, Apply Mergeable fs) => Mergeable (Sum fs) where
|
||||||
merge f = apply' @Mergeable (\ reinj g -> reinj <$> merge f g)
|
sequenceAlt = apply' @Mergeable (\ reinj t -> reinj <$> sequenceAlt t)
|
||||||
|
|
||||||
|
|
||||||
-- Generics
|
-- Generics
|
||||||
|
|
||||||
class GMergeable t where
|
class GMergeable t where
|
||||||
gmerge :: Alternative f => (a -> f b) -> t a -> f (t b)
|
gsequenceAlt :: Alternative f => t (f a) -> f (t a)
|
||||||
|
|
||||||
genericMerge :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => (a -> f b) -> t a -> f (t b)
|
genericSequenceAlt :: (Generic1 t, GMergeable (Rep1 t), Alternative f) => t (f a) -> f (t a)
|
||||||
genericMerge f = fmap to1 . gmerge f . from1
|
genericSequenceAlt = fmap to1 . gsequenceAlt . from1
|
||||||
|
|
||||||
|
|
||||||
-- Instances
|
-- Instances
|
||||||
|
|
||||||
instance GMergeable U1 where
|
instance GMergeable U1 where
|
||||||
gmerge _ _ = pure U1
|
gsequenceAlt _ = pure U1
|
||||||
|
|
||||||
instance GMergeable Par1 where
|
instance GMergeable Par1 where
|
||||||
gmerge f (Par1 a) = Par1 <$> f a
|
gsequenceAlt (Par1 a) = Par1 <$> a
|
||||||
|
|
||||||
instance GMergeable (K1 i c) where
|
instance GMergeable (K1 i c) where
|
||||||
gmerge _ (K1 a) = pure (K1 a)
|
gsequenceAlt (K1 a) = pure (K1 a)
|
||||||
|
|
||||||
instance Mergeable f => GMergeable (Rec1 f) where
|
instance Mergeable f => GMergeable (Rec1 f) where
|
||||||
gmerge f (Rec1 a) = Rec1 <$> merge f a
|
gsequenceAlt (Rec1 a) = Rec1 <$> sequenceAlt a
|
||||||
|
|
||||||
instance GMergeable f => GMergeable (M1 i c f) where
|
instance GMergeable f => GMergeable (M1 i c f) where
|
||||||
gmerge f (M1 a) = M1 <$> gmerge f a
|
gsequenceAlt (M1 a) = M1 <$> gsequenceAlt a
|
||||||
|
|
||||||
instance (GMergeable f, GMergeable g) => GMergeable (f :+: g) where
|
instance (GMergeable f, GMergeable g) => GMergeable (f :+: g) where
|
||||||
gmerge f (L1 a) = L1 <$> gmerge f a
|
gsequenceAlt (L1 a) = L1 <$> gsequenceAlt a
|
||||||
gmerge f (R1 b) = R1 <$> gmerge f b
|
gsequenceAlt (R1 a) = R1 <$> gsequenceAlt a
|
||||||
|
|
||||||
instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where
|
instance (GMergeable f, GMergeable g) => GMergeable (f :*: g) where
|
||||||
gmerge f (a :*: b) = (:*:) <$> gmerge f a <*> gmerge f b
|
gsequenceAlt (a :*: b) = (:*:) <$> gsequenceAlt a <*> gsequenceAlt b
|
||||||
|
@ -102,7 +102,7 @@ infixContext context left right operators = uncurry (&) <$> postContextualizeThr
|
|||||||
|
|
||||||
-- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
|
-- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
|
||||||
newtype Identifier a = Identifier Name
|
newtype Identifier a = Identifier Name
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Identifier where liftEq = genericLiftEq
|
instance Eq1 Identifier where liftEq = genericLiftEq
|
||||||
instance Ord1 Identifier where liftCompare = genericLiftCompare
|
instance Ord1 Identifier where liftCompare = genericLiftCompare
|
||||||
@ -121,7 +121,7 @@ instance Declarations1 Identifier where
|
|||||||
liftDeclaredName _ (Identifier x) = pure x
|
liftDeclaredName _ (Identifier x) = pure x
|
||||||
|
|
||||||
newtype Program a = Program [a]
|
newtype Program a = Program [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Program where liftEq = genericLiftEq
|
instance Eq1 Program where liftEq = genericLiftEq
|
||||||
instance Ord1 Program where liftCompare = genericLiftCompare
|
instance Ord1 Program where liftCompare = genericLiftCompare
|
||||||
@ -134,7 +134,7 @@ instance Evaluatable Program where
|
|||||||
|
|
||||||
-- | An accessibility modifier, e.g. private, public, protected, etc.
|
-- | An accessibility modifier, e.g. private, public, protected, etc.
|
||||||
newtype AccessibilityModifier a = AccessibilityModifier ByteString
|
newtype AccessibilityModifier a = AccessibilityModifier ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 AccessibilityModifier where liftEq = genericLiftEq
|
instance Eq1 AccessibilityModifier where liftEq = genericLiftEq
|
||||||
instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
|
instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
|
||||||
@ -149,7 +149,7 @@ instance Evaluatable AccessibilityModifier
|
|||||||
--
|
--
|
||||||
-- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
|
-- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
|
||||||
data Empty a = Empty
|
data Empty a = Empty
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Empty
|
instance ToJSONFields1 Empty
|
||||||
|
|
||||||
@ -158,12 +158,12 @@ instance Ord1 Empty where liftCompare _ _ _ = EQ
|
|||||||
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
|
instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
|
||||||
|
|
||||||
instance Evaluatable Empty where
|
instance Evaluatable Empty where
|
||||||
eval _ = Rval <$> unit
|
eval _ = pure (Rval unit)
|
||||||
|
|
||||||
|
|
||||||
-- | Syntax representing a parsing or assignment error.
|
-- | Syntax representing a parsing or assignment error.
|
||||||
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
|
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Error where liftEq = genericLiftEq
|
instance Eq1 Error where liftEq = genericLiftEq
|
||||||
instance Ord1 Error where liftCompare = genericLiftCompare
|
instance Ord1 Error where liftCompare = genericLiftCompare
|
||||||
@ -216,7 +216,7 @@ instance Ord ErrorStack where
|
|||||||
|
|
||||||
|
|
||||||
data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a }
|
data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a }
|
||||||
deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Eq, Foldable, Functor, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Context
|
instance ToJSONFields1 Context
|
||||||
|
|
||||||
|
@ -9,7 +9,7 @@ import Diffing.Algorithm
|
|||||||
|
|
||||||
-- | An unnested comment (line or block).
|
-- | An unnested comment (line or block).
|
||||||
newtype Comment a = Comment { commentContent :: ByteString }
|
newtype Comment a = Comment { commentContent :: ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Comment where liftEq = genericLiftEq
|
instance Eq1 Comment where liftEq = genericLiftEq
|
||||||
instance Ord1 Comment where liftCompare = genericLiftCompare
|
instance Ord1 Comment where liftCompare = genericLiftCompare
|
||||||
@ -19,7 +19,7 @@ instance ToJSONFields1 Comment where
|
|||||||
toJSONFields1 f@Comment{..} = withChildren f ["contents" .= unpack commentContent ]
|
toJSONFields1 f@Comment{..} = withChildren f ["contents" .= unpack commentContent ]
|
||||||
|
|
||||||
instance Evaluatable Comment where
|
instance Evaluatable Comment where
|
||||||
eval _ = Rval <$> unit
|
eval _ = pure (Rval unit)
|
||||||
|
|
||||||
-- TODO: nested comment types
|
-- TODO: nested comment types
|
||||||
-- TODO: documentation comment types
|
-- TODO: documentation comment types
|
||||||
|
@ -9,7 +9,7 @@ import Diffing.Algorithm
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
|
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
|
||||||
deriving (Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Diffable Function where
|
instance Diffable Function where
|
||||||
equivalentBySubterm = Just . functionName
|
equivalentBySubterm = Just . functionName
|
||||||
@ -27,7 +27,7 @@ instance Evaluatable Function where
|
|||||||
eval Function{..} = do
|
eval Function{..} = do
|
||||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
|
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
|
||||||
(v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody))
|
(v, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermValue functionBody))
|
||||||
modifyEnv (Env.insert name addr)
|
bind name addr
|
||||||
pure (Rval v)
|
pure (Rval v)
|
||||||
where paramNames = foldMap (freeVariables . subterm)
|
where paramNames = foldMap (freeVariables . subterm)
|
||||||
|
|
||||||
@ -36,7 +36,7 @@ instance Declarations a => Declarations (Function a) where
|
|||||||
|
|
||||||
|
|
||||||
data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a }
|
data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a }
|
||||||
deriving (Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Method where liftEq = genericLiftEq
|
instance Eq1 Method where liftEq = genericLiftEq
|
||||||
instance Ord1 Method where liftCompare = genericLiftCompare
|
instance Ord1 Method where liftCompare = genericLiftCompare
|
||||||
@ -53,14 +53,14 @@ instance Evaluatable Method where
|
|||||||
eval Method{..} = do
|
eval Method{..} = do
|
||||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
|
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
|
||||||
(v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody))
|
(v, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermValue methodBody))
|
||||||
modifyEnv (Env.insert name addr)
|
bind name addr
|
||||||
pure (Rval v)
|
pure (Rval v)
|
||||||
where paramNames = foldMap (freeVariables . subterm)
|
where paramNames = foldMap (freeVariables . subterm)
|
||||||
|
|
||||||
|
|
||||||
-- | A method signature in TypeScript or a method spec in Go.
|
-- | A method signature in TypeScript or a method spec in Go.
|
||||||
data MethodSignature a = MethodSignature { _methodSignatureContext :: ![a], _methodSignatureName :: !a, _methodSignatureParameters :: ![a] }
|
data MethodSignature a = MethodSignature { _methodSignatureContext :: ![a], _methodSignatureName :: !a, _methodSignatureParameters :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 MethodSignature where liftEq = genericLiftEq
|
instance Eq1 MethodSignature where liftEq = genericLiftEq
|
||||||
instance Ord1 MethodSignature where liftCompare = genericLiftCompare
|
instance Ord1 MethodSignature where liftCompare = genericLiftCompare
|
||||||
@ -73,7 +73,7 @@ instance Evaluatable MethodSignature
|
|||||||
|
|
||||||
|
|
||||||
newtype RequiredParameter a = RequiredParameter { requiredParameter :: a }
|
newtype RequiredParameter a = RequiredParameter { requiredParameter :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 RequiredParameter where liftEq = genericLiftEq
|
instance Eq1 RequiredParameter where liftEq = genericLiftEq
|
||||||
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
|
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
|
||||||
@ -86,7 +86,7 @@ instance Evaluatable RequiredParameter
|
|||||||
|
|
||||||
|
|
||||||
newtype OptionalParameter a = OptionalParameter { optionalParameter :: a }
|
newtype OptionalParameter a = OptionalParameter { optionalParameter :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 OptionalParameter where liftEq = genericLiftEq
|
instance Eq1 OptionalParameter where liftEq = genericLiftEq
|
||||||
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
|
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
|
||||||
@ -103,7 +103,7 @@ instance Evaluatable OptionalParameter
|
|||||||
-- TODO: It would be really nice to have a more meaningful type contained in here than [a]
|
-- TODO: It would be really nice to have a more meaningful type contained in here than [a]
|
||||||
-- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript.
|
-- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript.
|
||||||
newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] }
|
newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 VariableDeclaration where liftEq = genericLiftEq
|
instance Eq1 VariableDeclaration where liftEq = genericLiftEq
|
||||||
instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
|
instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
|
||||||
@ -112,8 +112,8 @@ instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 VariableDeclaration
|
instance ToJSONFields1 VariableDeclaration
|
||||||
|
|
||||||
instance Evaluatable VariableDeclaration where
|
instance Evaluatable VariableDeclaration where
|
||||||
eval (VariableDeclaration []) = Rval <$> unit
|
eval (VariableDeclaration []) = pure (Rval unit)
|
||||||
eval (VariableDeclaration decs) = Rval <$> (multiple =<< traverse subtermValue decs)
|
eval (VariableDeclaration decs) = Rval . multiple <$> traverse subtermValue decs
|
||||||
|
|
||||||
instance Declarations a => Declarations (VariableDeclaration a) where
|
instance Declarations a => Declarations (VariableDeclaration a) where
|
||||||
declaredName (VariableDeclaration vars) = case vars of
|
declaredName (VariableDeclaration vars) = case vars of
|
||||||
@ -123,7 +123,7 @@ instance Declarations a => Declarations (VariableDeclaration a) where
|
|||||||
|
|
||||||
-- | A TypeScript/Java style interface declaration to implement.
|
-- | A TypeScript/Java style interface declaration to implement.
|
||||||
data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationBody :: !a }
|
data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
|
instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
|
||||||
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
|
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
|
||||||
@ -140,7 +140,7 @@ instance Declarations a => Declarations (InterfaceDeclaration a) where
|
|||||||
|
|
||||||
-- | A public field definition such as a field definition in a JavaScript class.
|
-- | A public field definition such as a field definition in a JavaScript class.
|
||||||
data PublicFieldDefinition a = PublicFieldDefinition { publicFieldContext :: ![a], publicFieldPropertyName :: !a, publicFieldValue :: !a }
|
data PublicFieldDefinition a = PublicFieldDefinition { publicFieldContext :: ![a], publicFieldPropertyName :: !a, publicFieldValue :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 PublicFieldDefinition where liftEq = genericLiftEq
|
instance Eq1 PublicFieldDefinition where liftEq = genericLiftEq
|
||||||
instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
|
instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
|
||||||
@ -153,7 +153,7 @@ instance Evaluatable PublicFieldDefinition
|
|||||||
|
|
||||||
|
|
||||||
data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a }
|
data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Variable where liftEq = genericLiftEq
|
instance Eq1 Variable where liftEq = genericLiftEq
|
||||||
instance Ord1 Variable where liftCompare = genericLiftCompare
|
instance Ord1 Variable where liftCompare = genericLiftCompare
|
||||||
@ -165,7 +165,7 @@ instance ToJSONFields1 Variable
|
|||||||
instance Evaluatable Variable
|
instance Evaluatable Variable
|
||||||
|
|
||||||
data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a }
|
data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a }
|
||||||
deriving (Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Declarations a => Declarations (Class a) where
|
instance Declarations a => Declarations (Class a) where
|
||||||
declaredName (Class _ name _ _) = declaredName name
|
declaredName (Class _ name _ _) = declaredName name
|
||||||
@ -187,11 +187,11 @@ instance Evaluatable Class where
|
|||||||
void $ subtermValue classBody
|
void $ subtermValue classBody
|
||||||
classEnv <- Env.head <$> getEnv
|
classEnv <- Env.head <$> getEnv
|
||||||
klass name supers classEnv
|
klass name supers classEnv
|
||||||
Rval <$> (v <$ modifyEnv (Env.insert name addr))
|
Rval v <$ bind name addr
|
||||||
|
|
||||||
-- | A decorator in Python
|
-- | A decorator in Python
|
||||||
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
|
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Decorator where liftEq = genericLiftEq
|
instance Eq1 Decorator where liftEq = genericLiftEq
|
||||||
instance Ord1 Decorator where liftCompare = genericLiftCompare
|
instance Ord1 Decorator where liftCompare = genericLiftCompare
|
||||||
@ -207,7 +207,7 @@ instance Evaluatable Decorator
|
|||||||
|
|
||||||
-- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift.
|
-- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift.
|
||||||
data Datatype a = Datatype { datatypeName :: !a, datatypeConstructors :: ![a] }
|
data Datatype a = Datatype { datatypeName :: !a, datatypeConstructors :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq
|
instance Eq1 Data.Syntax.Declaration.Datatype where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCompare
|
instance Ord1 Data.Syntax.Declaration.Datatype where liftCompare = genericLiftCompare
|
||||||
@ -221,7 +221,7 @@ instance Evaluatable Data.Syntax.Declaration.Datatype
|
|||||||
|
|
||||||
-- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
|
-- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
|
||||||
data Constructor a = Constructor { constructorName :: !a, constructorFields :: ![a] }
|
data Constructor a = Constructor { constructorName :: !a, constructorFields :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
|
instance Eq1 Data.Syntax.Declaration.Constructor where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLiftCompare
|
instance Ord1 Data.Syntax.Declaration.Constructor where liftCompare = genericLiftCompare
|
||||||
@ -235,7 +235,7 @@ instance Evaluatable Data.Syntax.Declaration.Constructor
|
|||||||
|
|
||||||
-- | Comprehension (e.g. ((a for b in c if a()) in Python)
|
-- | Comprehension (e.g. ((a for b in c if a()) in Python)
|
||||||
data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBody :: !a }
|
data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Comprehension where liftEq = genericLiftEq
|
instance Eq1 Comprehension where liftEq = genericLiftEq
|
||||||
instance Ord1 Comprehension where liftCompare = genericLiftCompare
|
instance Ord1 Comprehension where liftCompare = genericLiftCompare
|
||||||
@ -249,7 +249,7 @@ instance Evaluatable Comprehension
|
|||||||
|
|
||||||
-- | A declared type (e.g. `a []int` in Go).
|
-- | A declared type (e.g. `a []int` in Go).
|
||||||
data Type a = Type { typeName :: !a, typeKind :: !a }
|
data Type a = Type { typeName :: !a, typeKind :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Type where liftEq = genericLiftEq
|
instance Eq1 Type where liftEq = genericLiftEq
|
||||||
instance Ord1 Type where liftCompare = genericLiftCompare
|
instance Ord1 Type where liftCompare = genericLiftCompare
|
||||||
@ -263,7 +263,7 @@ instance Evaluatable Type
|
|||||||
|
|
||||||
-- | Type alias declarations in Javascript/Haskell, etc.
|
-- | Type alias declarations in Javascript/Haskell, etc.
|
||||||
data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a }
|
data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 TypeAlias where liftEq = genericLiftEq
|
instance Eq1 TypeAlias where liftEq = genericLiftEq
|
||||||
instance Ord1 TypeAlias where liftCompare = genericLiftCompare
|
instance Ord1 TypeAlias where liftCompare = genericLiftCompare
|
||||||
@ -278,7 +278,7 @@ instance Evaluatable TypeAlias where
|
|||||||
v <- subtermValue typeAliasKind
|
v <- subtermValue typeAliasKind
|
||||||
addr <- lookupOrAlloc name
|
addr <- lookupOrAlloc name
|
||||||
assign addr v
|
assign addr v
|
||||||
Rval <$> (modifyEnv (Env.insert name addr) $> v)
|
Rval v <$ bind name addr
|
||||||
|
|
||||||
instance Declarations a => Declarations (TypeAlias a) where
|
instance Declarations a => Declarations (TypeAlias a) where
|
||||||
declaredName TypeAlias{..} = declaredName typeAliasIdentifier
|
declaredName TypeAlias{..} = declaredName typeAliasIdentifier
|
||||||
|
@ -11,7 +11,7 @@ import Prologue
|
|||||||
|
|
||||||
-- A file directive like the Ruby constant `__FILE__`.
|
-- A file directive like the Ruby constant `__FILE__`.
|
||||||
data File a = File
|
data File a = File
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 File where liftEq = genericLiftEq
|
instance Eq1 File where liftEq = genericLiftEq
|
||||||
instance Ord1 File where liftCompare = genericLiftCompare
|
instance Ord1 File where liftCompare = genericLiftCompare
|
||||||
@ -20,12 +20,12 @@ instance Show1 File where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 File
|
instance ToJSONFields1 File
|
||||||
|
|
||||||
instance Evaluatable File where
|
instance Evaluatable File where
|
||||||
eval File = Rval <$> (currentModule >>= string . BC.pack . modulePath)
|
eval File = Rval . string . BC.pack . modulePath <$> currentModule
|
||||||
|
|
||||||
|
|
||||||
-- A line directive like the Ruby constant `__LINE__`.
|
-- A line directive like the Ruby constant `__LINE__`.
|
||||||
data Line a = Line
|
data Line a = Line
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Line where liftEq = genericLiftEq
|
instance Eq1 Line where liftEq = genericLiftEq
|
||||||
instance Ord1 Line where liftCompare = genericLiftCompare
|
instance Ord1 Line where liftCompare = genericLiftCompare
|
||||||
@ -34,4 +34,4 @@ instance Show1 Line where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 Line
|
instance ToJSONFields1 Line
|
||||||
|
|
||||||
instance Evaluatable Line where
|
instance Evaluatable Line where
|
||||||
eval Line = Rval <$> (currentSpan >>= integer . fromIntegral . posLine . spanStart)
|
eval Line = Rval . integer . fromIntegral . posLine . spanStart <$> currentSpan
|
||||||
|
@ -10,7 +10,7 @@ import Prologue hiding (index)
|
|||||||
|
|
||||||
-- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
|
-- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
|
||||||
data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a }
|
data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Call where liftEq = genericLiftEq
|
instance Eq1 Call where liftEq = genericLiftEq
|
||||||
instance Ord1 Call where liftCompare = genericLiftCompare
|
instance Ord1 Call where liftCompare = genericLiftCompare
|
||||||
@ -31,7 +31,7 @@ data Comparison a
|
|||||||
| Equal !a !a
|
| Equal !a !a
|
||||||
| StrictEqual !a !a
|
| StrictEqual !a !a
|
||||||
| Comparison !a !a
|
| Comparison !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Comparison where liftEq = genericLiftEq
|
instance Eq1 Comparison where liftEq = genericLiftEq
|
||||||
instance Ord1 Comparison where liftCompare = genericLiftCompare
|
instance Ord1 Comparison where liftCompare = genericLiftCompare
|
||||||
@ -62,7 +62,7 @@ data Arithmetic a
|
|||||||
| Modulo !a !a
|
| Modulo !a !a
|
||||||
| Power !a !a
|
| Power !a !a
|
||||||
| Negate !a
|
| Negate !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Arithmetic where liftEq = genericLiftEq
|
instance Eq1 Arithmetic where liftEq = genericLiftEq
|
||||||
instance Ord1 Arithmetic where liftCompare = genericLiftCompare
|
instance Ord1 Arithmetic where liftCompare = genericLiftCompare
|
||||||
@ -85,7 +85,7 @@ instance Evaluatable Arithmetic where
|
|||||||
data Match a
|
data Match a
|
||||||
= Matches !a !a
|
= Matches !a !a
|
||||||
| NotMatches !a !a
|
| NotMatches !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Match where liftEq = genericLiftEq
|
instance Eq1 Match where liftEq = genericLiftEq
|
||||||
instance Ord1 Match where liftCompare = genericLiftCompare
|
instance Ord1 Match where liftCompare = genericLiftCompare
|
||||||
@ -102,7 +102,7 @@ data Boolean a
|
|||||||
| And !a !a
|
| And !a !a
|
||||||
| Not !a
|
| Not !a
|
||||||
| XOr !a !a
|
| XOr !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Boolean where liftEq = genericLiftEq
|
instance Eq1 Boolean where liftEq = genericLiftEq
|
||||||
instance Ord1 Boolean where liftCompare = genericLiftCompare
|
instance Ord1 Boolean where liftCompare = genericLiftCompare
|
||||||
@ -119,12 +119,12 @@ instance Evaluatable Boolean where
|
|||||||
go (Or a b) = do
|
go (Or a b) = do
|
||||||
cond <- a
|
cond <- a
|
||||||
ifthenelse cond (pure cond) b
|
ifthenelse cond (pure cond) b
|
||||||
go (Not a) = a >>= asBool >>= boolean . not
|
go (Not a) = a >>= fmap (boolean . not) . asBool
|
||||||
go (XOr a b) = liftA2 (/=) (a >>= asBool) (b >>= asBool) >>= boolean
|
go (XOr a b) = boolean <$> liftA2 (/=) (a >>= asBool) (b >>= asBool)
|
||||||
|
|
||||||
-- | Javascript delete operator
|
-- | Javascript delete operator
|
||||||
newtype Delete a = Delete a
|
newtype Delete a = Delete a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Delete where liftEq = genericLiftEq
|
instance Eq1 Delete where liftEq = genericLiftEq
|
||||||
instance Ord1 Delete where liftCompare = genericLiftCompare
|
instance Ord1 Delete where liftCompare = genericLiftCompare
|
||||||
@ -138,7 +138,7 @@ instance Evaluatable Delete
|
|||||||
|
|
||||||
-- | A sequence expression such as Javascript or C's comma operator.
|
-- | A sequence expression such as Javascript or C's comma operator.
|
||||||
data SequenceExpression a = SequenceExpression { _firstExpression :: !a, _secondExpression :: !a }
|
data SequenceExpression a = SequenceExpression { _firstExpression :: !a, _secondExpression :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 SequenceExpression where liftEq = genericLiftEq
|
instance Eq1 SequenceExpression where liftEq = genericLiftEq
|
||||||
instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
|
instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
|
||||||
@ -152,7 +152,7 @@ instance Evaluatable SequenceExpression
|
|||||||
|
|
||||||
-- | Javascript void operator
|
-- | Javascript void operator
|
||||||
newtype Void a = Void a
|
newtype Void a = Void a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Void where liftEq = genericLiftEq
|
instance Eq1 Void where liftEq = genericLiftEq
|
||||||
instance Ord1 Void where liftCompare = genericLiftCompare
|
instance Ord1 Void where liftCompare = genericLiftCompare
|
||||||
@ -166,7 +166,7 @@ instance Evaluatable Void
|
|||||||
|
|
||||||
-- | Javascript typeof operator
|
-- | Javascript typeof operator
|
||||||
newtype Typeof a = Typeof a
|
newtype Typeof a = Typeof a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Typeof where liftEq = genericLiftEq
|
instance Eq1 Typeof where liftEq = genericLiftEq
|
||||||
instance Ord1 Typeof where liftCompare = genericLiftCompare
|
instance Ord1 Typeof where liftCompare = genericLiftCompare
|
||||||
@ -187,7 +187,7 @@ data Bitwise a
|
|||||||
| RShift !a !a
|
| RShift !a !a
|
||||||
| UnsignedRShift !a !a
|
| UnsignedRShift !a !a
|
||||||
| Complement a
|
| Complement a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Bitwise where liftEq = genericLiftEq
|
instance Eq1 Bitwise where liftEq = genericLiftEq
|
||||||
instance Ord1 Bitwise where liftCompare = genericLiftCompare
|
instance Ord1 Bitwise where liftCompare = genericLiftCompare
|
||||||
@ -211,7 +211,7 @@ instance Evaluatable Bitwise where
|
|||||||
-- | Member Access (e.g. a.b)
|
-- | Member Access (e.g. a.b)
|
||||||
data MemberAccess a
|
data MemberAccess a
|
||||||
= MemberAccess !a !a
|
= MemberAccess !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 MemberAccess where liftEq = genericLiftEq
|
instance Eq1 MemberAccess where liftEq = genericLiftEq
|
||||||
instance Ord1 MemberAccess where liftCompare = genericLiftCompare
|
instance Ord1 MemberAccess where liftCompare = genericLiftCompare
|
||||||
@ -231,7 +231,7 @@ instance Evaluatable MemberAccess where
|
|||||||
data Subscript a
|
data Subscript a
|
||||||
= Subscript !a ![a]
|
= Subscript !a ![a]
|
||||||
| Member !a !a
|
| Member !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Subscript where liftEq = genericLiftEq
|
instance Eq1 Subscript where liftEq = genericLiftEq
|
||||||
instance Ord1 Subscript where liftCompare = genericLiftCompare
|
instance Ord1 Subscript where liftCompare = genericLiftCompare
|
||||||
@ -249,7 +249,7 @@ instance Evaluatable Subscript where
|
|||||||
|
|
||||||
-- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))
|
-- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))
|
||||||
data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a }
|
data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Enumeration where liftEq = genericLiftEq
|
instance Eq1 Enumeration where liftEq = genericLiftEq
|
||||||
instance Ord1 Enumeration where liftCompare = genericLiftCompare
|
instance Ord1 Enumeration where liftCompare = genericLiftCompare
|
||||||
@ -263,7 +263,7 @@ instance Evaluatable Enumeration
|
|||||||
|
|
||||||
-- | InstanceOf (e.g. a instanceof b in JavaScript
|
-- | InstanceOf (e.g. a instanceof b in JavaScript
|
||||||
data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a }
|
data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 InstanceOf where liftEq = genericLiftEq
|
instance Eq1 InstanceOf where liftEq = genericLiftEq
|
||||||
instance Ord1 InstanceOf where liftCompare = genericLiftCompare
|
instance Ord1 InstanceOf where liftCompare = genericLiftCompare
|
||||||
@ -277,7 +277,7 @@ instance Evaluatable InstanceOf
|
|||||||
|
|
||||||
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
|
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
|
||||||
newtype ScopeResolution a = ScopeResolution [a]
|
newtype ScopeResolution a = ScopeResolution [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 ScopeResolution where liftEq = genericLiftEq
|
instance Eq1 ScopeResolution where liftEq = genericLiftEq
|
||||||
instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
|
instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
|
||||||
@ -291,7 +291,7 @@ instance Evaluatable ScopeResolution
|
|||||||
|
|
||||||
-- | A non-null expression such as Typescript or Swift's ! expression.
|
-- | A non-null expression such as Typescript or Swift's ! expression.
|
||||||
newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a }
|
newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 NonNullExpression where liftEq = genericLiftEq
|
instance Eq1 NonNullExpression where liftEq = genericLiftEq
|
||||||
instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
|
instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
|
||||||
@ -305,7 +305,7 @@ instance Evaluatable NonNullExpression
|
|||||||
|
|
||||||
-- | An await expression in Javascript or C#.
|
-- | An await expression in Javascript or C#.
|
||||||
newtype Await a = Await { awaitSubject :: a }
|
newtype Await a = Await { awaitSubject :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Await where liftEq = genericLiftEq
|
instance Eq1 Await where liftEq = genericLiftEq
|
||||||
instance Ord1 Await where liftCompare = genericLiftCompare
|
instance Ord1 Await where liftCompare = genericLiftCompare
|
||||||
@ -319,7 +319,7 @@ instance Evaluatable Await
|
|||||||
|
|
||||||
-- | An object constructor call in Javascript, Java, etc.
|
-- | An object constructor call in Javascript, Java, etc.
|
||||||
newtype New a = New { newSubject :: [a] }
|
newtype New a = New { newSubject :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 New where liftEq = genericLiftEq
|
instance Eq1 New where liftEq = genericLiftEq
|
||||||
instance Ord1 New where liftCompare = genericLiftCompare
|
instance Ord1 New where liftCompare = genericLiftCompare
|
||||||
@ -333,7 +333,7 @@ instance Evaluatable New
|
|||||||
|
|
||||||
-- | A cast expression to a specified type.
|
-- | A cast expression to a specified type.
|
||||||
data Cast a = Cast { castSubject :: !a, castType :: !a }
|
data Cast a = Cast { castSubject :: !a, castType :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Cast where liftEq = genericLiftEq
|
instance Eq1 Cast where liftEq = genericLiftEq
|
||||||
instance Ord1 Cast where liftCompare = genericLiftCompare
|
instance Ord1 Cast where liftCompare = genericLiftCompare
|
||||||
|
@ -14,7 +14,7 @@ import Text.Read (readMaybe)
|
|||||||
-- Boolean
|
-- Boolean
|
||||||
|
|
||||||
newtype Boolean a = Boolean Bool
|
newtype Boolean a = Boolean Bool
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
true :: Boolean a
|
true :: Boolean a
|
||||||
true = Boolean True
|
true = Boolean True
|
||||||
@ -27,7 +27,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
instance Evaluatable Boolean where
|
instance Evaluatable Boolean where
|
||||||
eval (Boolean x) = Rval <$> boolean x
|
eval (Boolean x) = pure (Rval (boolean x))
|
||||||
|
|
||||||
instance ToJSONFields1 Boolean where
|
instance ToJSONFields1 Boolean where
|
||||||
toJSONFields1 (Boolean b) = noChildren [ "value" .= b ]
|
toJSONFields1 (Boolean b) = noChildren [ "value" .= b ]
|
||||||
@ -36,7 +36,7 @@ instance ToJSONFields1 Boolean where
|
|||||||
|
|
||||||
-- | A literal integer of unspecified width. No particular base is implied.
|
-- | A literal integer of unspecified width. No particular base is implied.
|
||||||
newtype Integer a = Integer { integerContent :: ByteString }
|
newtype Integer a = Integer { integerContent :: ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
|
instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare
|
instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare
|
||||||
@ -45,7 +45,7 @@ instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShow
|
|||||||
instance Evaluatable Data.Syntax.Literal.Integer where
|
instance Evaluatable Data.Syntax.Literal.Integer where
|
||||||
-- TODO: This instance probably shouldn't have readInteger?
|
-- TODO: This instance probably shouldn't have readInteger?
|
||||||
eval (Data.Syntax.Literal.Integer x) =
|
eval (Data.Syntax.Literal.Integer x) =
|
||||||
Rval <$> (integer =<< maybeM (throwEvalError (IntegerFormatError x)) (fst <$> readInteger x))
|
Rval . integer <$> maybeM (throwEvalError (IntegerFormatError x)) (fst <$> readInteger x)
|
||||||
|
|
||||||
instance ToJSONFields1 Data.Syntax.Literal.Integer where
|
instance ToJSONFields1 Data.Syntax.Literal.Integer where
|
||||||
toJSONFields1 (Integer i) = noChildren ["asString" .= unpack i]
|
toJSONFields1 (Integer i) = noChildren ["asString" .= unpack i]
|
||||||
@ -57,7 +57,7 @@ instance ToJSONFields1 Data.Syntax.Literal.Integer where
|
|||||||
|
|
||||||
-- | A literal float of unspecified width.
|
-- | A literal float of unspecified width.
|
||||||
newtype Float a = Float { floatContent :: ByteString }
|
newtype Float a = Float { floatContent :: ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
|
instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
|
instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
|
||||||
@ -65,14 +65,14 @@ instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsP
|
|||||||
|
|
||||||
instance Evaluatable Data.Syntax.Literal.Float where
|
instance Evaluatable Data.Syntax.Literal.Float where
|
||||||
eval (Float s) =
|
eval (Float s) =
|
||||||
Rval <$> (float =<< either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s))
|
Rval . float <$> either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s)
|
||||||
|
|
||||||
instance ToJSONFields1 Float where
|
instance ToJSONFields1 Float where
|
||||||
toJSONFields1 (Float f) = noChildren ["asString" .= unpack f]
|
toJSONFields1 (Float f) = noChildren ["asString" .= unpack f]
|
||||||
|
|
||||||
-- Rational literals e.g. `2/3r`
|
-- Rational literals e.g. `2/3r`
|
||||||
newtype Rational a = Rational ByteString
|
newtype Rational a = Rational ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq
|
instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompare
|
instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompare
|
||||||
@ -83,14 +83,14 @@ instance Evaluatable Data.Syntax.Literal.Rational where
|
|||||||
let
|
let
|
||||||
trimmed = B.takeWhile (/= 'r') r
|
trimmed = B.takeWhile (/= 'r') r
|
||||||
parsed = readMaybe @Prelude.Integer (unpack trimmed)
|
parsed = readMaybe @Prelude.Integer (unpack trimmed)
|
||||||
in Rval <$> (rational =<< maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed)
|
in Rval . rational <$> maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed
|
||||||
|
|
||||||
instance ToJSONFields1 Data.Syntax.Literal.Rational where
|
instance ToJSONFields1 Data.Syntax.Literal.Rational where
|
||||||
toJSONFields1 (Rational r) = noChildren ["asString" .= unpack r]
|
toJSONFields1 (Rational r) = noChildren ["asString" .= unpack r]
|
||||||
|
|
||||||
-- Complex literals e.g. `3 + 2i`
|
-- Complex literals e.g. `3 + 2i`
|
||||||
newtype Complex a = Complex ByteString
|
newtype Complex a = Complex ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Data.Syntax.Literal.Complex where liftEq = genericLiftEq
|
instance Eq1 Data.Syntax.Literal.Complex where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Literal.Complex where liftCompare = genericLiftCompare
|
instance Ord1 Data.Syntax.Literal.Complex where liftCompare = genericLiftCompare
|
||||||
@ -105,7 +105,7 @@ instance ToJSONFields1 Complex where
|
|||||||
-- Strings, symbols
|
-- Strings, symbols
|
||||||
|
|
||||||
newtype String a = String { stringElements :: [a] }
|
newtype String a = String { stringElements :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq
|
instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq
|
||||||
instance Ord1 Data.Syntax.Literal.String where liftCompare = genericLiftCompare
|
instance Ord1 Data.Syntax.Literal.String where liftCompare = genericLiftCompare
|
||||||
@ -131,7 +131,7 @@ instance ToJSONFields1 Data.Syntax.Literal.Character
|
|||||||
|
|
||||||
-- | An interpolation element within a string literal.
|
-- | An interpolation element within a string literal.
|
||||||
newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
|
newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 InterpolationElement where liftEq = genericLiftEq
|
instance Eq1 InterpolationElement where liftEq = genericLiftEq
|
||||||
instance Ord1 InterpolationElement where liftCompare = genericLiftCompare
|
instance Ord1 InterpolationElement where liftCompare = genericLiftCompare
|
||||||
@ -144,7 +144,7 @@ instance ToJSONFields1 InterpolationElement
|
|||||||
|
|
||||||
-- | A sequence of textual contents within a string literal.
|
-- | A sequence of textual contents within a string literal.
|
||||||
newtype TextElement a = TextElement { textElementContent :: ByteString }
|
newtype TextElement a = TextElement { textElementContent :: ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 TextElement where liftEq = genericLiftEq
|
instance Eq1 TextElement where liftEq = genericLiftEq
|
||||||
instance Ord1 TextElement where liftCompare = genericLiftCompare
|
instance Ord1 TextElement where liftCompare = genericLiftCompare
|
||||||
@ -154,21 +154,21 @@ instance ToJSONFields1 TextElement where
|
|||||||
toJSONFields1 (TextElement c) = noChildren ["asString" .= unpack c]
|
toJSONFields1 (TextElement c) = noChildren ["asString" .= unpack c]
|
||||||
|
|
||||||
instance Evaluatable TextElement where
|
instance Evaluatable TextElement where
|
||||||
eval (TextElement x) = Rval <$> string x
|
eval (TextElement x) = pure (Rval (string x))
|
||||||
|
|
||||||
data Null a = Null
|
data Null a = Null
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Null where liftEq = genericLiftEq
|
instance Eq1 Null where liftEq = genericLiftEq
|
||||||
instance Ord1 Null where liftCompare = genericLiftCompare
|
instance Ord1 Null where liftCompare = genericLiftCompare
|
||||||
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
instance Evaluatable Null where eval _ = Rval <$> null
|
instance Evaluatable Null where eval _ = pure (Rval null)
|
||||||
|
|
||||||
instance ToJSONFields1 Null
|
instance ToJSONFields1 Null
|
||||||
|
|
||||||
newtype Symbol a = Symbol { symbolContent :: ByteString }
|
newtype Symbol a = Symbol { symbolContent :: ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Symbol where liftEq = genericLiftEq
|
instance Eq1 Symbol where liftEq = genericLiftEq
|
||||||
instance Ord1 Symbol where liftCompare = genericLiftCompare
|
instance Ord1 Symbol where liftCompare = genericLiftCompare
|
||||||
@ -177,10 +177,10 @@ instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 Symbol
|
instance ToJSONFields1 Symbol
|
||||||
|
|
||||||
instance Evaluatable Symbol where
|
instance Evaluatable Symbol where
|
||||||
eval (Symbol s) = Rval <$> symbol s
|
eval (Symbol s) = pure (Rval (symbol s))
|
||||||
|
|
||||||
newtype Regex a = Regex { regexContent :: ByteString }
|
newtype Regex a = Regex { regexContent :: ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Regex where liftEq = genericLiftEq
|
instance Eq1 Regex where liftEq = genericLiftEq
|
||||||
instance Ord1 Regex where liftCompare = genericLiftCompare
|
instance Ord1 Regex where liftCompare = genericLiftCompare
|
||||||
@ -199,7 +199,7 @@ instance Evaluatable Regex
|
|||||||
-- Collections
|
-- Collections
|
||||||
|
|
||||||
newtype Array a = Array { arrayElements :: [a] }
|
newtype Array a = Array { arrayElements :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Array where liftEq = genericLiftEq
|
instance Eq1 Array where liftEq = genericLiftEq
|
||||||
instance Ord1 Array where liftCompare = genericLiftCompare
|
instance Ord1 Array where liftCompare = genericLiftCompare
|
||||||
@ -211,7 +211,7 @@ instance Evaluatable Array where
|
|||||||
eval (Array a) = Rval <$> (array =<< traverse subtermValue a)
|
eval (Array a) = Rval <$> (array =<< traverse subtermValue a)
|
||||||
|
|
||||||
newtype Hash a = Hash { hashElements :: [a] }
|
newtype Hash a = Hash { hashElements :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Hash where liftEq = genericLiftEq
|
instance Eq1 Hash where liftEq = genericLiftEq
|
||||||
instance Ord1 Hash where liftCompare = genericLiftCompare
|
instance Ord1 Hash where liftCompare = genericLiftCompare
|
||||||
@ -220,10 +220,10 @@ instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 Hash
|
instance ToJSONFields1 Hash
|
||||||
|
|
||||||
instance Evaluatable Hash where
|
instance Evaluatable Hash where
|
||||||
eval t = Rval <$> (traverse (subtermValue >=> asPair) (hashElements t) >>= hash)
|
eval t = Rval . hash <$> traverse (subtermValue >=> asPair) (hashElements t)
|
||||||
|
|
||||||
data KeyValue a = KeyValue { key :: !a, value :: !a }
|
data KeyValue a = KeyValue { key :: !a, value :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 KeyValue where liftEq = genericLiftEq
|
instance Eq1 KeyValue where liftEq = genericLiftEq
|
||||||
instance Ord1 KeyValue where liftCompare = genericLiftCompare
|
instance Ord1 KeyValue where liftCompare = genericLiftCompare
|
||||||
@ -233,22 +233,22 @@ instance ToJSONFields1 KeyValue
|
|||||||
|
|
||||||
instance Evaluatable KeyValue where
|
instance Evaluatable KeyValue where
|
||||||
eval (fmap subtermValue -> KeyValue{..}) =
|
eval (fmap subtermValue -> KeyValue{..}) =
|
||||||
Rval <$> join (kvPair <$> key <*> value)
|
Rval <$> (kvPair <$> key <*> value)
|
||||||
|
|
||||||
instance ToJSONFields1 Tuple
|
instance ToJSONFields1 Tuple
|
||||||
|
|
||||||
newtype Tuple a = Tuple { tupleContents :: [a] }
|
newtype Tuple a = Tuple { tupleContents :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Tuple where liftEq = genericLiftEq
|
instance Eq1 Tuple where liftEq = genericLiftEq
|
||||||
instance Ord1 Tuple where liftCompare = genericLiftCompare
|
instance Ord1 Tuple where liftCompare = genericLiftCompare
|
||||||
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
instance Evaluatable Tuple where
|
instance Evaluatable Tuple where
|
||||||
eval (Tuple cs) = Rval <$> (multiple =<< traverse subtermValue cs)
|
eval (Tuple cs) = Rval . multiple <$> traverse subtermValue cs
|
||||||
|
|
||||||
newtype Set a = Set { setElements :: [a] }
|
newtype Set a = Set { setElements :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Set where liftEq = genericLiftEq
|
instance Eq1 Set where liftEq = genericLiftEq
|
||||||
instance Ord1 Set where liftCompare = genericLiftCompare
|
instance Ord1 Set where liftCompare = genericLiftCompare
|
||||||
@ -264,7 +264,7 @@ instance Evaluatable Set
|
|||||||
|
|
||||||
-- | A declared pointer (e.g. var pointer *int in Go)
|
-- | A declared pointer (e.g. var pointer *int in Go)
|
||||||
newtype Pointer a = Pointer a
|
newtype Pointer a = Pointer a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Pointer where liftEq = genericLiftEq
|
instance Eq1 Pointer where liftEq = genericLiftEq
|
||||||
instance Ord1 Pointer where liftCompare = genericLiftCompare
|
instance Ord1 Pointer where liftCompare = genericLiftCompare
|
||||||
@ -278,7 +278,7 @@ instance Evaluatable Pointer
|
|||||||
|
|
||||||
-- | A reference to a pointer's address (e.g. &pointer in Go)
|
-- | A reference to a pointer's address (e.g. &pointer in Go)
|
||||||
newtype Reference a = Reference a
|
newtype Reference a = Reference a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Reference where liftEq = genericLiftEq
|
instance Eq1 Reference where liftEq = genericLiftEq
|
||||||
instance Ord1 Reference where liftCompare = genericLiftCompare
|
instance Ord1 Reference where liftCompare = genericLiftCompare
|
||||||
|
@ -1,7 +1,6 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
|
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
|
||||||
module Data.Syntax.Statement where
|
module Data.Syntax.Statement where
|
||||||
|
|
||||||
import qualified Data.Abstract.Environment as Env
|
|
||||||
import Data.Abstract.Evaluatable
|
import Data.Abstract.Evaluatable
|
||||||
import Data.ByteString.Char8 (unpack)
|
import Data.ByteString.Char8 (unpack)
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
@ -11,7 +10,7 @@ import Prologue
|
|||||||
|
|
||||||
-- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted.
|
-- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted.
|
||||||
data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
|
data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 If where liftEq = genericLiftEq
|
instance Eq1 If where liftEq = genericLiftEq
|
||||||
instance Ord1 If where liftCompare = genericLiftCompare
|
instance Ord1 If where liftCompare = genericLiftCompare
|
||||||
@ -26,7 +25,7 @@ instance Evaluatable If where
|
|||||||
|
|
||||||
-- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python.
|
-- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python.
|
||||||
data Else a = Else { elseCondition :: !a, elseBody :: !a }
|
data Else a = Else { elseCondition :: !a, elseBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Else where liftEq = genericLiftEq
|
instance Eq1 Else where liftEq = genericLiftEq
|
||||||
instance Ord1 Else where liftCompare = genericLiftCompare
|
instance Ord1 Else where liftCompare = genericLiftCompare
|
||||||
@ -41,7 +40,7 @@ instance Evaluatable Else
|
|||||||
|
|
||||||
-- | Goto statement (e.g. `goto a` in Go).
|
-- | Goto statement (e.g. `goto a` in Go).
|
||||||
newtype Goto a = Goto { gotoLocation :: a }
|
newtype Goto a = Goto { gotoLocation :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Goto where liftEq = genericLiftEq
|
instance Eq1 Goto where liftEq = genericLiftEq
|
||||||
instance Ord1 Goto where liftCompare = genericLiftCompare
|
instance Ord1 Goto where liftCompare = genericLiftCompare
|
||||||
@ -55,7 +54,7 @@ instance Evaluatable Goto
|
|||||||
|
|
||||||
-- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell.
|
-- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell.
|
||||||
data Match a = Match { matchSubject :: !a, matchPatterns :: !a }
|
data Match a = Match { matchSubject :: !a, matchPatterns :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Match where liftEq = genericLiftEq
|
instance Eq1 Match where liftEq = genericLiftEq
|
||||||
instance Ord1 Match where liftCompare = genericLiftCompare
|
instance Ord1 Match where liftCompare = genericLiftCompare
|
||||||
@ -69,7 +68,7 @@ instance Evaluatable Match
|
|||||||
|
|
||||||
-- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions.
|
-- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions.
|
||||||
data Pattern a = Pattern { _pattern :: !a, patternBody :: !a }
|
data Pattern a = Pattern { _pattern :: !a, patternBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Pattern where liftEq = genericLiftEq
|
instance Eq1 Pattern where liftEq = genericLiftEq
|
||||||
instance Ord1 Pattern where liftCompare = genericLiftCompare
|
instance Ord1 Pattern where liftCompare = genericLiftCompare
|
||||||
@ -83,7 +82,7 @@ instance Evaluatable Pattern
|
|||||||
|
|
||||||
-- | A let statement or local binding, like 'a as b' or 'let a = b'.
|
-- | A let statement or local binding, like 'a as b' or 'let a = b'.
|
||||||
data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
|
data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Let where liftEq = genericLiftEq
|
instance Eq1 Let where liftEq = genericLiftEq
|
||||||
instance Ord1 Let where liftCompare = genericLiftCompare
|
instance Ord1 Let where liftCompare = genericLiftCompare
|
||||||
@ -95,14 +94,14 @@ instance Evaluatable Let where
|
|||||||
eval Let{..} = do
|
eval Let{..} = do
|
||||||
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm letVariable)
|
name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm letVariable)
|
||||||
addr <- snd <$> letrec name (subtermValue letValue)
|
addr <- snd <$> letrec name (subtermValue letValue)
|
||||||
Rval <$> localEnv (Env.insert name addr) (subtermValue letBody)
|
Rval <$> locally (bind name addr *> subtermValue letBody)
|
||||||
|
|
||||||
|
|
||||||
-- Assignment
|
-- Assignment
|
||||||
|
|
||||||
-- | Assignment to a variable or other lvalue.
|
-- | Assignment to a variable or other lvalue.
|
||||||
data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
|
data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Assignment where liftEq = genericLiftEq
|
instance Eq1 Assignment where liftEq = genericLiftEq
|
||||||
instance Ord1 Assignment where liftCompare = genericLiftCompare
|
instance Ord1 Assignment where liftCompare = genericLiftCompare
|
||||||
@ -119,7 +118,7 @@ instance Evaluatable Assignment where
|
|||||||
LvalLocal nam -> do
|
LvalLocal nam -> do
|
||||||
addr <- lookupOrAlloc nam
|
addr <- lookupOrAlloc nam
|
||||||
assign addr rhs
|
assign addr rhs
|
||||||
modifyEnv (Env.insert nam addr)
|
bind nam addr
|
||||||
LvalMember _ _ ->
|
LvalMember _ _ ->
|
||||||
-- we don't yet support mutable object properties:
|
-- we don't yet support mutable object properties:
|
||||||
pure ()
|
pure ()
|
||||||
@ -131,7 +130,7 @@ instance Evaluatable Assignment where
|
|||||||
|
|
||||||
-- | Post increment operator (e.g. 1++ in Go, or i++ in C).
|
-- | Post increment operator (e.g. 1++ in Go, or i++ in C).
|
||||||
newtype PostIncrement a = PostIncrement a
|
newtype PostIncrement a = PostIncrement a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 PostIncrement where liftEq = genericLiftEq
|
instance Eq1 PostIncrement where liftEq = genericLiftEq
|
||||||
instance Ord1 PostIncrement where liftCompare = genericLiftCompare
|
instance Ord1 PostIncrement where liftCompare = genericLiftCompare
|
||||||
@ -145,7 +144,7 @@ instance Evaluatable PostIncrement
|
|||||||
|
|
||||||
-- | Post decrement operator (e.g. 1-- in Go, or i-- in C).
|
-- | Post decrement operator (e.g. 1-- in Go, or i-- in C).
|
||||||
newtype PostDecrement a = PostDecrement a
|
newtype PostDecrement a = PostDecrement a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 PostDecrement where liftEq = genericLiftEq
|
instance Eq1 PostDecrement where liftEq = genericLiftEq
|
||||||
instance Ord1 PostDecrement where liftCompare = genericLiftCompare
|
instance Ord1 PostDecrement where liftCompare = genericLiftCompare
|
||||||
@ -160,7 +159,7 @@ instance Evaluatable PostDecrement
|
|||||||
-- Returns
|
-- Returns
|
||||||
|
|
||||||
newtype Return a = Return a
|
newtype Return a = Return a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Return where liftEq = genericLiftEq
|
instance Eq1 Return where liftEq = genericLiftEq
|
||||||
instance Ord1 Return where liftCompare = genericLiftCompare
|
instance Ord1 Return where liftCompare = genericLiftCompare
|
||||||
@ -172,7 +171,7 @@ instance Evaluatable Return where
|
|||||||
eval (Return x) = Rval <$> (subtermValue x >>= earlyReturn)
|
eval (Return x) = Rval <$> (subtermValue x >>= earlyReturn)
|
||||||
|
|
||||||
newtype Yield a = Yield a
|
newtype Yield a = Yield a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Yield where liftEq = genericLiftEq
|
instance Eq1 Yield where liftEq = genericLiftEq
|
||||||
instance Ord1 Yield where liftCompare = genericLiftCompare
|
instance Ord1 Yield where liftCompare = genericLiftCompare
|
||||||
@ -185,7 +184,7 @@ instance Evaluatable Yield
|
|||||||
|
|
||||||
|
|
||||||
newtype Break a = Break a
|
newtype Break a = Break a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Break where liftEq = genericLiftEq
|
instance Eq1 Break where liftEq = genericLiftEq
|
||||||
instance Ord1 Break where liftCompare = genericLiftCompare
|
instance Ord1 Break where liftCompare = genericLiftCompare
|
||||||
@ -197,7 +196,7 @@ instance Evaluatable Break where
|
|||||||
eval (Break x) = Rval <$> (subtermValue x >>= throwBreak)
|
eval (Break x) = Rval <$> (subtermValue x >>= throwBreak)
|
||||||
|
|
||||||
newtype Continue a = Continue a
|
newtype Continue a = Continue a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Continue where liftEq = genericLiftEq
|
instance Eq1 Continue where liftEq = genericLiftEq
|
||||||
instance Ord1 Continue where liftCompare = genericLiftCompare
|
instance Ord1 Continue where liftCompare = genericLiftCompare
|
||||||
@ -209,7 +208,7 @@ instance Evaluatable Continue where
|
|||||||
eval (Continue a) = Rval <$> (subtermValue a >>= throwContinue)
|
eval (Continue a) = Rval <$> (subtermValue a >>= throwContinue)
|
||||||
|
|
||||||
newtype Retry a = Retry a
|
newtype Retry a = Retry a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Retry where liftEq = genericLiftEq
|
instance Eq1 Retry where liftEq = genericLiftEq
|
||||||
instance Ord1 Retry where liftCompare = genericLiftCompare
|
instance Ord1 Retry where liftCompare = genericLiftCompare
|
||||||
@ -222,7 +221,7 @@ instance Evaluatable Retry
|
|||||||
|
|
||||||
|
|
||||||
newtype NoOp a = NoOp a
|
newtype NoOp a = NoOp a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 NoOp where liftEq = genericLiftEq
|
instance Eq1 NoOp where liftEq = genericLiftEq
|
||||||
instance Ord1 NoOp where liftCompare = genericLiftCompare
|
instance Ord1 NoOp where liftCompare = genericLiftCompare
|
||||||
@ -231,12 +230,12 @@ instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 NoOp
|
instance ToJSONFields1 NoOp
|
||||||
|
|
||||||
instance Evaluatable NoOp where
|
instance Evaluatable NoOp where
|
||||||
eval _ = Rval <$> unit
|
eval _ = pure (Rval unit)
|
||||||
|
|
||||||
-- Loops
|
-- Loops
|
||||||
|
|
||||||
data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
|
data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 For where liftEq = genericLiftEq
|
instance Eq1 For where liftEq = genericLiftEq
|
||||||
instance Ord1 For where liftCompare = genericLiftCompare
|
instance Ord1 For where liftCompare = genericLiftCompare
|
||||||
@ -249,7 +248,7 @@ instance Evaluatable For where
|
|||||||
|
|
||||||
|
|
||||||
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
|
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 ForEach where liftEq = genericLiftEq
|
instance Eq1 ForEach where liftEq = genericLiftEq
|
||||||
instance Ord1 ForEach where liftCompare = genericLiftCompare
|
instance Ord1 ForEach where liftCompare = genericLiftCompare
|
||||||
@ -262,7 +261,7 @@ instance Evaluatable ForEach
|
|||||||
|
|
||||||
|
|
||||||
data While a = While { whileCondition :: !a, whileBody :: !a }
|
data While a = While { whileCondition :: !a, whileBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 While where liftEq = genericLiftEq
|
instance Eq1 While where liftEq = genericLiftEq
|
||||||
instance Ord1 While where liftCompare = genericLiftCompare
|
instance Ord1 While where liftCompare = genericLiftCompare
|
||||||
@ -274,7 +273,7 @@ instance Evaluatable While where
|
|||||||
eval While{..} = Rval <$> while (subtermValue whileCondition) (subtermValue whileBody)
|
eval While{..} = Rval <$> while (subtermValue whileCondition) (subtermValue whileBody)
|
||||||
|
|
||||||
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
|
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 DoWhile where liftEq = genericLiftEq
|
instance Eq1 DoWhile where liftEq = genericLiftEq
|
||||||
instance Ord1 DoWhile where liftCompare = genericLiftCompare
|
instance Ord1 DoWhile where liftCompare = genericLiftCompare
|
||||||
@ -288,7 +287,7 @@ instance Evaluatable DoWhile where
|
|||||||
-- Exception handling
|
-- Exception handling
|
||||||
|
|
||||||
newtype Throw a = Throw a
|
newtype Throw a = Throw a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Throw where liftEq = genericLiftEq
|
instance Eq1 Throw where liftEq = genericLiftEq
|
||||||
instance Ord1 Throw where liftCompare = genericLiftCompare
|
instance Ord1 Throw where liftCompare = genericLiftCompare
|
||||||
@ -301,7 +300,7 @@ instance Evaluatable Throw
|
|||||||
|
|
||||||
|
|
||||||
data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
|
data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Try where liftEq = genericLiftEq
|
instance Eq1 Try where liftEq = genericLiftEq
|
||||||
instance Ord1 Try where liftCompare = genericLiftCompare
|
instance Ord1 Try where liftCompare = genericLiftCompare
|
||||||
@ -314,7 +313,7 @@ instance Evaluatable Try
|
|||||||
|
|
||||||
|
|
||||||
data Catch a = Catch { catchException :: !a, catchBody :: !a }
|
data Catch a = Catch { catchException :: !a, catchBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Catch where liftEq = genericLiftEq
|
instance Eq1 Catch where liftEq = genericLiftEq
|
||||||
instance Ord1 Catch where liftCompare = genericLiftCompare
|
instance Ord1 Catch where liftCompare = genericLiftCompare
|
||||||
@ -327,7 +326,7 @@ instance Evaluatable Catch
|
|||||||
|
|
||||||
|
|
||||||
newtype Finally a = Finally a
|
newtype Finally a = Finally a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Finally where liftEq = genericLiftEq
|
instance Eq1 Finally where liftEq = genericLiftEq
|
||||||
instance Ord1 Finally where liftCompare = genericLiftCompare
|
instance Ord1 Finally where liftCompare = genericLiftCompare
|
||||||
@ -343,7 +342,7 @@ instance Evaluatable Finally
|
|||||||
|
|
||||||
-- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl).
|
-- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl).
|
||||||
newtype ScopeEntry a = ScopeEntry [a]
|
newtype ScopeEntry a = ScopeEntry [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 ScopeEntry where liftEq = genericLiftEq
|
instance Eq1 ScopeEntry where liftEq = genericLiftEq
|
||||||
instance Ord1 ScopeEntry where liftCompare = genericLiftCompare
|
instance Ord1 ScopeEntry where liftCompare = genericLiftCompare
|
||||||
@ -357,7 +356,7 @@ instance Evaluatable ScopeEntry
|
|||||||
|
|
||||||
-- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
|
-- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
|
||||||
newtype ScopeExit a = ScopeExit [a]
|
newtype ScopeExit a = ScopeExit [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 ScopeExit where liftEq = genericLiftEq
|
instance Eq1 ScopeExit where liftEq = genericLiftEq
|
||||||
instance Ord1 ScopeExit where liftCompare = genericLiftCompare
|
instance Ord1 ScopeExit where liftCompare = genericLiftCompare
|
||||||
@ -370,7 +369,7 @@ instance Evaluatable ScopeExit
|
|||||||
|
|
||||||
-- | HashBang line (e.g. `#!/usr/bin/env node`)
|
-- | HashBang line (e.g. `#!/usr/bin/env node`)
|
||||||
newtype HashBang a = HashBang ByteString
|
newtype HashBang a = HashBang ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 HashBang where liftEq = genericLiftEq
|
instance Eq1 HashBang where liftEq = genericLiftEq
|
||||||
instance Ord1 HashBang where liftCompare = genericLiftCompare
|
instance Ord1 HashBang where liftCompare = genericLiftCompare
|
||||||
|
@ -7,7 +7,7 @@ import Diffing.Algorithm
|
|||||||
import Prologue hiding (Map)
|
import Prologue hiding (Map)
|
||||||
|
|
||||||
data Array a = Array { arraySize :: Maybe a, arrayElementType :: a }
|
data Array a = Array { arraySize :: Maybe a, arrayElementType :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Array where liftEq = genericLiftEq
|
instance Eq1 Array where liftEq = genericLiftEq
|
||||||
instance Ord1 Array where liftCompare = genericLiftCompare
|
instance Ord1 Array where liftCompare = genericLiftCompare
|
||||||
@ -21,7 +21,7 @@ instance Evaluatable Array
|
|||||||
|
|
||||||
-- TODO: What about type variables? re: FreeVariables1
|
-- TODO: What about type variables? re: FreeVariables1
|
||||||
data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a }
|
data Annotation a = Annotation { annotationSubject :: !a, annotationType :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Annotation where liftEq = genericLiftEq
|
instance Eq1 Annotation where liftEq = genericLiftEq
|
||||||
instance Ord1 Annotation where liftCompare = genericLiftCompare
|
instance Ord1 Annotation where liftCompare = genericLiftCompare
|
||||||
@ -35,7 +35,7 @@ instance Evaluatable Annotation where
|
|||||||
|
|
||||||
|
|
||||||
data Function a = Function { functionParameters :: [a], functionReturn :: a }
|
data Function a = Function { functionParameters :: [a], functionReturn :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Function where liftEq = genericLiftEq
|
instance Eq1 Function where liftEq = genericLiftEq
|
||||||
instance Ord1 Function where liftCompare = genericLiftCompare
|
instance Ord1 Function where liftCompare = genericLiftCompare
|
||||||
@ -48,7 +48,7 @@ instance Evaluatable Function
|
|||||||
|
|
||||||
|
|
||||||
newtype Interface a = Interface [a]
|
newtype Interface a = Interface [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Interface where liftEq = genericLiftEq
|
instance Eq1 Interface where liftEq = genericLiftEq
|
||||||
instance Ord1 Interface where liftCompare = genericLiftCompare
|
instance Ord1 Interface where liftCompare = genericLiftCompare
|
||||||
@ -61,7 +61,7 @@ instance Evaluatable Interface
|
|||||||
|
|
||||||
|
|
||||||
data Map a = Map { mapKeyType :: a, mapElementType :: a }
|
data Map a = Map { mapKeyType :: a, mapElementType :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Map where liftEq = genericLiftEq
|
instance Eq1 Map where liftEq = genericLiftEq
|
||||||
instance Ord1 Map where liftCompare = genericLiftCompare
|
instance Ord1 Map where liftCompare = genericLiftCompare
|
||||||
@ -74,7 +74,7 @@ instance Evaluatable Map
|
|||||||
|
|
||||||
|
|
||||||
newtype Parenthesized a = Parenthesized a
|
newtype Parenthesized a = Parenthesized a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Parenthesized where liftEq = genericLiftEq
|
instance Eq1 Parenthesized where liftEq = genericLiftEq
|
||||||
instance Ord1 Parenthesized where liftCompare = genericLiftCompare
|
instance Ord1 Parenthesized where liftCompare = genericLiftCompare
|
||||||
@ -87,7 +87,7 @@ instance Evaluatable Parenthesized
|
|||||||
|
|
||||||
|
|
||||||
newtype Pointer a = Pointer a
|
newtype Pointer a = Pointer a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Pointer where liftEq = genericLiftEq
|
instance Eq1 Pointer where liftEq = genericLiftEq
|
||||||
instance Ord1 Pointer where liftCompare = genericLiftCompare
|
instance Ord1 Pointer where liftCompare = genericLiftCompare
|
||||||
@ -100,7 +100,7 @@ instance Evaluatable Pointer
|
|||||||
|
|
||||||
|
|
||||||
newtype Product a = Product [a]
|
newtype Product a = Product [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Product where liftEq = genericLiftEq
|
instance Eq1 Product where liftEq = genericLiftEq
|
||||||
instance Ord1 Product where liftCompare = genericLiftCompare
|
instance Ord1 Product where liftCompare = genericLiftCompare
|
||||||
@ -113,7 +113,7 @@ instance Evaluatable Product
|
|||||||
|
|
||||||
|
|
||||||
data Readonly a = Readonly
|
data Readonly a = Readonly
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Readonly where liftEq = genericLiftEq
|
instance Eq1 Readonly where liftEq = genericLiftEq
|
||||||
instance Ord1 Readonly where liftCompare = genericLiftCompare
|
instance Ord1 Readonly where liftCompare = genericLiftCompare
|
||||||
@ -126,7 +126,7 @@ instance Evaluatable Readonly
|
|||||||
|
|
||||||
|
|
||||||
newtype Slice a = Slice a
|
newtype Slice a = Slice a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Slice where liftEq = genericLiftEq
|
instance Eq1 Slice where liftEq = genericLiftEq
|
||||||
instance Ord1 Slice where liftCompare = genericLiftCompare
|
instance Ord1 Slice where liftCompare = genericLiftCompare
|
||||||
@ -139,7 +139,7 @@ instance Evaluatable Slice
|
|||||||
|
|
||||||
|
|
||||||
newtype TypeParameters a = TypeParameters [a]
|
newtype TypeParameters a = TypeParameters [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 TypeParameters where liftEq = genericLiftEq
|
instance Eq1 TypeParameters where liftEq = genericLiftEq
|
||||||
instance Ord1 TypeParameters where liftCompare = genericLiftCompare
|
instance Ord1 TypeParameters where liftCompare = genericLiftCompare
|
||||||
|
@ -1,5 +1,4 @@
|
|||||||
{-# LANGUAGE DataKinds, DefaultSignatures, GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
|
{-# LANGUAGE DefaultSignatures, GADTs, TypeOperators, UndecidableInstances #-}
|
||||||
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- FIXME
|
|
||||||
module Diffing.Algorithm where
|
module Diffing.Algorithm where
|
||||||
|
|
||||||
import Control.Monad.Free.Freer
|
import Control.Monad.Free.Freer
|
||||||
@ -143,6 +142,10 @@ class Diffable f where
|
|||||||
-> Algorithm term1 term2 result (f result)
|
-> Algorithm term1 term2 result (f result)
|
||||||
algorithmFor = genericAlgorithmFor
|
algorithmFor = genericAlgorithmFor
|
||||||
|
|
||||||
|
tryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
|
||||||
|
default tryAlignWith :: (Alternative g, Generic1 f, GDiffable (Rep1 f)) => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
|
||||||
|
tryAlignWith f a b = to1 <$> gtryAlignWith f (from1 a) (from1 b)
|
||||||
|
|
||||||
-- | Construct an algorithm to diff against positions inside an @f@.
|
-- | Construct an algorithm to diff against positions inside an @f@.
|
||||||
--
|
--
|
||||||
-- This is very like 'traverse', with two key differences:
|
-- This is very like 'traverse', with two key differences:
|
||||||
@ -190,6 +193,8 @@ genericComparableTo a1 a2 = gcomparableTo (from1 a1) (from1 a2)
|
|||||||
instance Apply Diffable fs => Diffable (Sum fs) where
|
instance Apply Diffable fs => Diffable (Sum fs) where
|
||||||
algorithmFor u1 u2 = fromMaybe empty (apply2' @Diffable (\ inj f1 f2 -> inj <$> algorithmFor f1 f2) u1 u2)
|
algorithmFor u1 u2 = fromMaybe empty (apply2' @Diffable (\ inj f1 f2 -> inj <$> algorithmFor f1 f2) u1 u2)
|
||||||
|
|
||||||
|
tryAlignWith f u1 u2 = fromMaybe empty (apply2' @Diffable (\ inj t1 t2 -> inj <$> tryAlignWith f t1 t2) u1 u2)
|
||||||
|
|
||||||
subalgorithmFor blur focus = apply' @Diffable (\ inj f -> inj <$> subalgorithmFor blur focus f)
|
subalgorithmFor blur focus = apply' @Diffable (\ inj f -> inj <$> subalgorithmFor blur focus f)
|
||||||
|
|
||||||
equivalentBySubterm = apply @Diffable equivalentBySubterm
|
equivalentBySubterm = apply @Diffable equivalentBySubterm
|
||||||
@ -201,18 +206,31 @@ instance Apply Diffable fs => Diffable (Sum fs) where
|
|||||||
instance Diffable Maybe where
|
instance Diffable Maybe where
|
||||||
algorithmFor = diffMaybe
|
algorithmFor = diffMaybe
|
||||||
|
|
||||||
|
tryAlignWith f (Just a1) (Just a2) = Just <$> f (These a1 a2)
|
||||||
|
tryAlignWith f (Just a1) Nothing = Just <$> f (This a1)
|
||||||
|
tryAlignWith f Nothing (Just a2) = Just <$> f (That a2)
|
||||||
|
tryAlignWith _ Nothing Nothing = pure Nothing
|
||||||
|
|
||||||
-- | Diff two lists using RWS.
|
-- | Diff two lists using RWS.
|
||||||
instance Diffable [] where
|
instance Diffable [] where
|
||||||
algorithmFor = byRWS
|
algorithmFor = byRWS
|
||||||
|
|
||||||
|
tryAlignWith f (a1:as1) (a2:as2) = (:) <$> f (These a1 a2) <*> tryAlignWith f as1 as2
|
||||||
|
tryAlignWith f [] as2 = traverse (f . That) as2
|
||||||
|
tryAlignWith f as1 [] = traverse (f . This) as1
|
||||||
|
|
||||||
-- | Diff two non-empty lists using RWS.
|
-- | Diff two non-empty lists using RWS.
|
||||||
instance Diffable NonEmpty where
|
instance Diffable NonEmpty where
|
||||||
algorithmFor (a1:|as1) (a2:|as2) = (\ (a:as) -> a:|as) <$> byRWS (a1:as1) (a2:as2)
|
algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybe empty pure
|
||||||
|
|
||||||
|
tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (These a1 a2) <*> tryAlignWith f as1 as2
|
||||||
|
|
||||||
-- | A generic type class for diffing two terms defined by the Generic1 interface.
|
-- | A generic type class for diffing two terms defined by the Generic1 interface.
|
||||||
class GDiffable f where
|
class GDiffable f where
|
||||||
galgorithmFor :: f term1 -> f term2 -> Algorithm term1 term2 result (f result)
|
galgorithmFor :: f term1 -> f term2 -> Algorithm term1 term2 result (f result)
|
||||||
|
|
||||||
|
gtryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
|
||||||
|
|
||||||
gcomparableTo :: f term1 -> f term2 -> Bool
|
gcomparableTo :: f term1 -> f term2 -> Bool
|
||||||
gcomparableTo _ _ = True
|
gcomparableTo _ _ = True
|
||||||
|
|
||||||
@ -220,6 +238,8 @@ class GDiffable f where
|
|||||||
instance GDiffable f => GDiffable (M1 i c f) where
|
instance GDiffable f => GDiffable (M1 i c f) where
|
||||||
galgorithmFor (M1 a1) (M1 a2) = M1 <$> galgorithmFor a1 a2
|
galgorithmFor (M1 a1) (M1 a2) = M1 <$> galgorithmFor a1 a2
|
||||||
|
|
||||||
|
gtryAlignWith f (M1 a) (M1 b) = M1 <$> gtryAlignWith f a b
|
||||||
|
|
||||||
gcomparableTo (M1 a1) (M1 a2) = gcomparableTo a1 a2
|
gcomparableTo (M1 a1) (M1 a2) = gcomparableTo a1 a2
|
||||||
|
|
||||||
-- | Diff the fields of a product type.
|
-- | Diff the fields of a product type.
|
||||||
@ -227,6 +247,8 @@ instance GDiffable f => GDiffable (M1 i c f) where
|
|||||||
instance (GDiffable f, GDiffable g) => GDiffable (f :*: g) where
|
instance (GDiffable f, GDiffable g) => GDiffable (f :*: g) where
|
||||||
galgorithmFor (a1 :*: b1) (a2 :*: b2) = (:*:) <$> galgorithmFor a1 a2 <*> galgorithmFor b1 b2
|
galgorithmFor (a1 :*: b1) (a2 :*: b2) = (:*:) <$> galgorithmFor a1 a2 <*> galgorithmFor b1 b2
|
||||||
|
|
||||||
|
gtryAlignWith f (a1 :*: b1) (a2 :*: b2) = (:*:) <$> gtryAlignWith f a1 a2 <*> gtryAlignWith f b1 b2
|
||||||
|
|
||||||
-- | Diff the constructors of a sum type.
|
-- | Diff the constructors of a sum type.
|
||||||
-- i.e. data Foo a = Foo a | Bar a (the 'Foo a' is captured by L1 and 'Bar a' is R1).
|
-- i.e. data Foo a = Foo a | Bar a (the 'Foo a' is captured by L1 and 'Bar a' is R1).
|
||||||
instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where
|
instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where
|
||||||
@ -234,6 +256,11 @@ instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where
|
|||||||
galgorithmFor (R1 b1) (R1 b2) = R1 <$> galgorithmFor b1 b2
|
galgorithmFor (R1 b1) (R1 b2) = R1 <$> galgorithmFor b1 b2
|
||||||
galgorithmFor _ _ = empty
|
galgorithmFor _ _ = empty
|
||||||
|
|
||||||
|
gtryAlignWith f a b = case (a, b) of
|
||||||
|
(L1 a, L1 b) -> L1 <$> gtryAlignWith f a b
|
||||||
|
(R1 a, R1 b) -> R1 <$> gtryAlignWith f a b
|
||||||
|
_ -> empty
|
||||||
|
|
||||||
gcomparableTo (L1 _) (L1 _) = True
|
gcomparableTo (L1 _) (L1 _) = True
|
||||||
gcomparableTo (R1 _) (R1 _) = True
|
gcomparableTo (R1 _) (R1 _) = True
|
||||||
gcomparableTo _ _ = False
|
gcomparableTo _ _ = False
|
||||||
@ -243,18 +270,26 @@ instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where
|
|||||||
instance GDiffable Par1 where
|
instance GDiffable Par1 where
|
||||||
galgorithmFor (Par1 a1) (Par1 a2) = Par1 <$> diff a1 a2
|
galgorithmFor (Par1 a1) (Par1 a2) = Par1 <$> diff a1 a2
|
||||||
|
|
||||||
|
gtryAlignWith f (Par1 a) (Par1 b) = Par1 <$> f (These a b)
|
||||||
|
|
||||||
-- | Diff two constant parameters (K1 is the Generic1 newtype representing type parameter constants).
|
-- | Diff two constant parameters (K1 is the Generic1 newtype representing type parameter constants).
|
||||||
-- i.e. data Foo = Foo Int (the 'Int' is a constant parameter).
|
-- i.e. data Foo = Foo Int (the 'Int' is a constant parameter).
|
||||||
instance Eq c => GDiffable (K1 i c) where
|
instance Eq c => GDiffable (K1 i c) where
|
||||||
galgorithmFor (K1 a1) (K1 a2) = guard (a1 == a2) $> K1 a1
|
galgorithmFor (K1 a1) (K1 a2) = guard (a1 == a2) $> K1 a1
|
||||||
|
|
||||||
|
gtryAlignWith _ (K1 a) (K1 b) = guard (a == b) $> K1 b
|
||||||
|
|
||||||
-- | Diff two terms whose constructors contain 0 type parameters.
|
-- | Diff two terms whose constructors contain 0 type parameters.
|
||||||
-- i.e. data Foo = Foo.
|
-- i.e. data Foo = Foo.
|
||||||
instance GDiffable U1 where
|
instance GDiffable U1 where
|
||||||
galgorithmFor _ _ = pure U1
|
galgorithmFor _ _ = pure U1
|
||||||
|
|
||||||
|
gtryAlignWith _ _ _ = pure U1
|
||||||
|
|
||||||
-- | Diff two 'Diffable' containers of parameters.
|
-- | Diff two 'Diffable' containers of parameters.
|
||||||
instance Diffable f => GDiffable (Rec1 f) where
|
instance Diffable f => GDiffable (Rec1 f) where
|
||||||
galgorithmFor a1 a2 = Rec1 <$> algorithmFor (unRec1 a1) (unRec1 a2)
|
galgorithmFor a1 a2 = Rec1 <$> algorithmFor (unRec1 a1) (unRec1 a2)
|
||||||
|
|
||||||
|
gtryAlignWith f (Rec1 a) (Rec1 b) = Rec1 <$> tryAlignWith f a b
|
||||||
|
|
||||||
{-# ANN module ("HLint: ignore Avoid return" :: String) #-}
|
{-# ANN module ("HLint: ignore Avoid return" :: String) #-}
|
||||||
|
@ -14,23 +14,23 @@ module Diffing.Algorithm.RWS
|
|||||||
, equalTerms
|
, equalTerms
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prologue
|
|
||||||
import Data.Align.Generic (galignWith)
|
|
||||||
import Control.Monad.State.Strict
|
import Control.Monad.State.Strict
|
||||||
import Data.Diff (DiffF(..), deleting, inserting, merge, replacing)
|
import Data.Diff (DiffF(..), deleting, inserting, merge, replacing)
|
||||||
import qualified Data.KdMap.Static as KdMap
|
import qualified Data.KdMap.Static as KdMap
|
||||||
import Data.List (sortOn)
|
import Data.List (sortOn)
|
||||||
import Data.Record
|
import Data.Record
|
||||||
import Data.Term as Term
|
import Data.Term as Term
|
||||||
|
import Diffing.Algorithm
|
||||||
import Diffing.Algorithm.RWS.FeatureVector
|
import Diffing.Algorithm.RWS.FeatureVector
|
||||||
import Diffing.Algorithm.SES
|
import Diffing.Algorithm.SES
|
||||||
|
import Prologue
|
||||||
|
|
||||||
-- | A relation on 'Term's, guaranteed constant-time in the size of the 'Term' by parametricity.
|
-- | A relation on 'Term's, guaranteed constant-time in the size of the 'Term' by parametricity.
|
||||||
--
|
--
|
||||||
-- This is used both to determine whether two root terms can be compared in O(1), and, recursively, to determine whether two nodes are equal in O(n); thus, comparability is defined s.t. two terms are equal if they are recursively comparable subterm-wise.
|
-- This is used both to determine whether two root terms can be compared in O(1), and, recursively, to determine whether two nodes are equal in O(n); thus, comparability is defined s.t. two terms are equal if they are recursively comparable subterm-wise.
|
||||||
type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool
|
type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool
|
||||||
|
|
||||||
rws :: (Foldable syntax, Functor syntax, GAlign syntax)
|
rws :: (Foldable syntax, Functor syntax, Diffable syntax)
|
||||||
=> ComparabilityRelation syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))
|
=> ComparabilityRelation syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))
|
||||||
-> (Term syntax (Record (FeatureVector ': fields1)) -> Term syntax (Record (FeatureVector ': fields2)) -> Bool)
|
-> (Term syntax (Record (FeatureVector ': fields1)) -> Term syntax (Record (FeatureVector ': fields2)) -> Bool)
|
||||||
-> [Term syntax (Record (FeatureVector ': fields1))]
|
-> [Term syntax (Record (FeatureVector ': fields1))]
|
||||||
@ -153,13 +153,13 @@ equalTerms canCompare = go
|
|||||||
-- | Return an edit distance between two terms, up to a certain depth.
|
-- | Return an edit distance between two terms, up to a certain depth.
|
||||||
--
|
--
|
||||||
-- Computes a constant-time approximation to the edit distance of a diff. This is done by comparing at most _m_ nodes, & assuming the rest are zero-cost.
|
-- Computes a constant-time approximation to the edit distance of a diff. This is done by comparing at most _m_ nodes, & assuming the rest are zero-cost.
|
||||||
editDistanceUpTo :: (GAlign syntax, Foldable syntax, Functor syntax) => Int -> Term syntax ann1 -> Term syntax ann2 -> Int
|
editDistanceUpTo :: (Diffable syntax, Foldable syntax, Functor syntax) => Int -> Term syntax ann1 -> Term syntax ann2 -> Int
|
||||||
editDistanceUpTo m a b = diffCost m (approximateDiff a b)
|
editDistanceUpTo m a b = diffCost m (approximateDiff a b)
|
||||||
where diffCost = flip . cata $ \ diff m -> case diff of
|
where diffCost = flip . cata $ \ diff m -> case diff of
|
||||||
_ | m <= 0 -> 0
|
_ | m <= 0 -> 0
|
||||||
Merge body -> sum (fmap ($ pred m) body)
|
Merge body -> sum (fmap ($ pred m) body)
|
||||||
body -> succ (sum (fmap ($ pred m) body))
|
body -> succ (sum (fmap ($ pred m) body))
|
||||||
approximateDiff a b = maybe (replacing a b) (merge (termAnnotation a, termAnnotation b)) (galignWith (Just . these deleting inserting approximateDiff) (termOut a) (termOut b))
|
approximateDiff a b = maybe (replacing a b) (merge (termAnnotation a, termAnnotation b)) (tryAlignWith (Just . these deleting inserting approximateDiff) (termOut a) (termOut b))
|
||||||
|
|
||||||
|
|
||||||
data Label syntax where
|
data Label syntax where
|
||||||
|
@ -1,11 +1,10 @@
|
|||||||
{-# LANGUAGE DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-}
|
{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
|
||||||
module Diffing.Interpreter
|
module Diffing.Interpreter
|
||||||
( diffTerms
|
( diffTerms
|
||||||
, diffTermPair
|
, diffTermPair
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.Free.Freer
|
import Control.Monad.Free.Freer
|
||||||
import Data.Align.Generic (galignWith)
|
|
||||||
import Data.Diff
|
import Data.Diff
|
||||||
import Data.Record
|
import Data.Record
|
||||||
import Data.Term
|
import Data.Term
|
||||||
@ -14,7 +13,7 @@ import Diffing.Algorithm.RWS
|
|||||||
import Prologue
|
import Prologue
|
||||||
|
|
||||||
-- | Diff two à la carte terms recursively.
|
-- | Diff two à la carte terms recursively.
|
||||||
diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax)
|
diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax)
|
||||||
=> Term syntax (Record fields1)
|
=> Term syntax (Record fields1)
|
||||||
-> Term syntax (Record fields2)
|
-> Term syntax (Record fields2)
|
||||||
-> Diff syntax (Record fields1) (Record fields2)
|
-> Diff syntax (Record fields1) (Record fields2)
|
||||||
@ -23,22 +22,21 @@ diffTerms t1 t2 = stripDiff (fromMaybe (replacing t1' t2') (runAlgorithm (diff t
|
|||||||
, defaultFeatureVectorDecorator t2)
|
, defaultFeatureVectorDecorator t2)
|
||||||
|
|
||||||
-- | Diff a 'These' of terms.
|
-- | Diff a 'These' of terms.
|
||||||
diffTermPair :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Diff syntax (Record fields1) (Record fields2)
|
diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Diff syntax (Record fields1) (Record fields2)
|
||||||
diffTermPair = these deleting inserting diffTerms
|
diffTermPair = these deleting inserting diffTerms
|
||||||
|
|
||||||
|
|
||||||
-- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
|
-- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
|
||||||
runAlgorithm :: forall syntax fields1 fields2 m result
|
runAlgorithm :: (Diffable syntax, Eq1 syntax, Traversable syntax, Alternative m, Monad m)
|
||||||
. (Diffable syntax, Eq1 syntax, GAlign syntax, Traversable syntax, Alternative m, Monad m)
|
|
||||||
=> Algorithm
|
=> Algorithm
|
||||||
(Term syntax (Record (FeatureVector ': fields1)))
|
(Term syntax (Record (FeatureVector ': fields1)))
|
||||||
(Term syntax (Record (FeatureVector ': fields2)))
|
(Term syntax (Record (FeatureVector ': fields2)))
|
||||||
(Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)))
|
(Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)))
|
||||||
result
|
result
|
||||||
-> m result
|
-> m result
|
||||||
runAlgorithm = iterFreerA (\ yield step -> case step of
|
runAlgorithm = iterFreerA (\ yield step -> case step of
|
||||||
Diffing.Algorithm.Diff t1 t2 -> runAlgorithm (algorithmForTerms t1 t2) <|> pure (replacing t1 t2) >>= yield
|
Diffing.Algorithm.Diff t1 t2 -> runAlgorithm (algorithmForTerms t1 t2) <|> pure (replacing t1 t2) >>= yield
|
||||||
Linear (Term (In ann1 f1)) (Term (In ann2 f2)) -> merge (ann1, ann2) <$> galignWith (runAlgorithm . diffThese) f1 f2 >>= yield
|
Linear (Term (In ann1 f1)) (Term (In ann2 f2)) -> merge (ann1, ann2) <$> tryAlignWith (runAlgorithm . diffThese) f1 f2 >>= yield
|
||||||
RWS as bs -> traverse (runAlgorithm . diffThese) (rws comparableTerms equivalentTerms as bs) >>= yield
|
RWS as bs -> traverse (runAlgorithm . diffThese) (rws comparableTerms equivalentTerms as bs) >>= yield
|
||||||
Delete a -> yield (deleting a)
|
Delete a -> yield (deleting a)
|
||||||
Insert b -> yield (inserting b)
|
Insert b -> yield (inserting b)
|
||||||
|
@ -28,14 +28,14 @@ importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (path
|
|||||||
defaultAlias :: ImportPath -> Name
|
defaultAlias :: ImportPath -> Name
|
||||||
defaultAlias = name . BC.pack . takeFileName . unPath
|
defaultAlias = name . BC.pack . takeFileName . unPath
|
||||||
|
|
||||||
resolveGoImport :: Members '[ Modules location value
|
resolveGoImport :: ( Member (Modules address value) effects
|
||||||
, Reader ModuleInfo
|
, Member (Reader ModuleInfo) effects
|
||||||
, Reader Package.PackageInfo
|
, Member (Reader Package.PackageInfo) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
)
|
||||||
=> ImportPath
|
=> ImportPath
|
||||||
-> Evaluator location value effects [ModulePath]
|
-> Evaluator address value effects [ModulePath]
|
||||||
resolveGoImport (ImportPath path Relative) = do
|
resolveGoImport (ImportPath path Relative) = do
|
||||||
ModuleInfo{..} <- currentModule
|
ModuleInfo{..} <- currentModule
|
||||||
paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path)
|
paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path)
|
||||||
@ -56,7 +56,7 @@ resolveGoImport (ImportPath path NonRelative) = do
|
|||||||
--
|
--
|
||||||
-- If the list of symbols is empty copy everything to the calling environment.
|
-- If the list of symbols is empty copy everything to the calling environment.
|
||||||
data Import a = Import { importFrom :: ImportPath, importWildcardToken :: !a }
|
data Import a = Import { importFrom :: ImportPath, importWildcardToken :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Import where liftEq = genericLiftEq
|
instance Eq1 Import where liftEq = genericLiftEq
|
||||||
instance Ord1 Import where liftCompare = genericLiftCompare
|
instance Ord1 Import where liftCompare = genericLiftCompare
|
||||||
@ -70,15 +70,15 @@ instance Evaluatable Import where
|
|||||||
for_ paths $ \path -> do
|
for_ paths $ \path -> do
|
||||||
traceResolve (unPath importPath) path
|
traceResolve (unPath importPath) path
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||||
modifyEnv (mergeEnvs importedEnv)
|
bindAll importedEnv
|
||||||
Rval <$> unit
|
pure (Rval unit)
|
||||||
|
|
||||||
|
|
||||||
-- | Qualified Import declarations (symbols are qualified in calling environment).
|
-- | Qualified Import declarations (symbols are qualified in calling environment).
|
||||||
--
|
--
|
||||||
-- If the list of symbols is empty copy and qualify everything to the calling environment.
|
-- If the list of symbols is empty copy and qualify everything to the calling environment.
|
||||||
data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, qualifiedImportAlias :: !a}
|
data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, qualifiedImportAlias :: !a}
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 QualifiedImport where liftEq = genericLiftEq
|
instance Eq1 QualifiedImport where liftEq = genericLiftEq
|
||||||
instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
|
instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
|
||||||
@ -94,13 +94,13 @@ instance Evaluatable QualifiedImport where
|
|||||||
for_ paths $ \p -> do
|
for_ paths $ \p -> do
|
||||||
traceResolve (unPath importPath) p
|
traceResolve (unPath importPath) p
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require p)
|
importedEnv <- maybe emptyEnv fst <$> isolate (require p)
|
||||||
modifyEnv (mergeEnvs importedEnv)
|
bindAll importedEnv
|
||||||
makeNamespace alias addr Nothing
|
makeNamespace alias addr Nothing
|
||||||
Rval <$> unit
|
pure (Rval unit)
|
||||||
|
|
||||||
-- | Side effect only imports (no symbols made available to the calling environment).
|
-- | Side effect only imports (no symbols made available to the calling environment).
|
||||||
data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a }
|
data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 SideEffectImport where liftEq = genericLiftEq
|
instance Eq1 SideEffectImport where liftEq = genericLiftEq
|
||||||
instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
|
instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
|
||||||
@ -113,11 +113,11 @@ instance Evaluatable SideEffectImport where
|
|||||||
paths <- resolveGoImport importPath
|
paths <- resolveGoImport importPath
|
||||||
traceResolve (unPath importPath) paths
|
traceResolve (unPath importPath) paths
|
||||||
for_ paths $ \path -> isolate (require path)
|
for_ paths $ \path -> isolate (require path)
|
||||||
Rval <$> unit
|
pure (Rval unit)
|
||||||
|
|
||||||
-- A composite literal in Go
|
-- A composite literal in Go
|
||||||
data Composite a = Composite { compositeType :: !a, compositeElement :: !a }
|
data Composite a = Composite { compositeType :: !a, compositeElement :: !a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Composite where liftEq = genericLiftEq
|
instance Eq1 Composite where liftEq = genericLiftEq
|
||||||
instance Ord1 Composite where liftCompare = genericLiftCompare
|
instance Ord1 Composite where liftCompare = genericLiftCompare
|
||||||
@ -130,7 +130,7 @@ instance Evaluatable Composite
|
|||||||
|
|
||||||
-- | A default pattern in a Go select or switch statement (e.g. `switch { default: s() }`).
|
-- | A default pattern in a Go select or switch statement (e.g. `switch { default: s() }`).
|
||||||
newtype DefaultPattern a = DefaultPattern { defaultPatternBody :: a }
|
newtype DefaultPattern a = DefaultPattern { defaultPatternBody :: a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 DefaultPattern where liftEq = genericLiftEq
|
instance Eq1 DefaultPattern where liftEq = genericLiftEq
|
||||||
instance Ord1 DefaultPattern where liftCompare = genericLiftCompare
|
instance Ord1 DefaultPattern where liftCompare = genericLiftCompare
|
||||||
@ -143,7 +143,7 @@ instance Evaluatable DefaultPattern
|
|||||||
|
|
||||||
-- | A defer statement in Go (e.g. `defer x()`).
|
-- | A defer statement in Go (e.g. `defer x()`).
|
||||||
newtype Defer a = Defer { deferBody :: a }
|
newtype Defer a = Defer { deferBody :: a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Defer where liftEq = genericLiftEq
|
instance Eq1 Defer where liftEq = genericLiftEq
|
||||||
instance Ord1 Defer where liftCompare = genericLiftCompare
|
instance Ord1 Defer where liftCompare = genericLiftCompare
|
||||||
@ -156,7 +156,7 @@ instance Evaluatable Defer
|
|||||||
|
|
||||||
-- | A go statement (i.e. go routine) in Go (e.g. `go x()`).
|
-- | A go statement (i.e. go routine) in Go (e.g. `go x()`).
|
||||||
newtype Go a = Go { goBody :: a }
|
newtype Go a = Go { goBody :: a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Go where liftEq = genericLiftEq
|
instance Eq1 Go where liftEq = genericLiftEq
|
||||||
instance Ord1 Go where liftCompare = genericLiftCompare
|
instance Ord1 Go where liftCompare = genericLiftCompare
|
||||||
@ -169,7 +169,7 @@ instance Evaluatable Go
|
|||||||
|
|
||||||
-- | A label statement in Go (e.g. `label:continue`).
|
-- | A label statement in Go (e.g. `label:continue`).
|
||||||
data Label a = Label { _labelName :: !a, labelStatement :: !a }
|
data Label a = Label { _labelName :: !a, labelStatement :: !a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Label where liftEq = genericLiftEq
|
instance Eq1 Label where liftEq = genericLiftEq
|
||||||
instance Ord1 Label where liftCompare = genericLiftCompare
|
instance Ord1 Label where liftCompare = genericLiftCompare
|
||||||
@ -182,7 +182,7 @@ instance Evaluatable Label
|
|||||||
|
|
||||||
-- | A rune literal in Go (e.g. `'⌘'`).
|
-- | A rune literal in Go (e.g. `'⌘'`).
|
||||||
newtype Rune a = Rune { _runeLiteral :: ByteString }
|
newtype Rune a = Rune { _runeLiteral :: ByteString }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Rune
|
instance ToJSONFields1 Rune
|
||||||
|
|
||||||
@ -195,7 +195,7 @@ instance Show1 Rune where liftShowsPrec = genericLiftShowsPrec
|
|||||||
|
|
||||||
-- | A select statement in Go (e.g. `select { case x := <-c: x() }` where each case is a send or receive operation on channels).
|
-- | A select statement in Go (e.g. `select { case x := <-c: x() }` where each case is a send or receive operation on channels).
|
||||||
newtype Select a = Select { selectCases :: a }
|
newtype Select a = Select { selectCases :: a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Select
|
instance ToJSONFields1 Select
|
||||||
|
|
||||||
@ -208,7 +208,7 @@ instance Show1 Select where liftShowsPrec = genericLiftShowsPrec
|
|||||||
|
|
||||||
-- | A send statement in Go (e.g. `channel <- value`).
|
-- | A send statement in Go (e.g. `channel <- value`).
|
||||||
data Send a = Send { sendReceiver :: !a, sendValue :: !a }
|
data Send a = Send { sendReceiver :: !a, sendValue :: !a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Send where liftEq = genericLiftEq
|
instance Eq1 Send where liftEq = genericLiftEq
|
||||||
instance Ord1 Send where liftCompare = genericLiftCompare
|
instance Ord1 Send where liftCompare = genericLiftCompare
|
||||||
@ -221,7 +221,7 @@ instance Evaluatable Send
|
|||||||
|
|
||||||
-- | A slice expression in Go (e.g. `a[1:4:3]` where a is a list, 1 is the low bound, 4 is the high bound, and 3 is the max capacity).
|
-- | A slice expression in Go (e.g. `a[1:4:3]` where a is a list, 1 is the low bound, 4 is the high bound, and 3 is the max capacity).
|
||||||
data Slice a = Slice { sliceName :: !a, sliceLow :: !a, sliceHigh :: !a, sliceCapacity :: !a }
|
data Slice a = Slice { sliceName :: !a, sliceLow :: !a, sliceHigh :: !a, sliceCapacity :: !a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Slice where liftEq = genericLiftEq
|
instance Eq1 Slice where liftEq = genericLiftEq
|
||||||
instance Ord1 Slice where liftCompare = genericLiftCompare
|
instance Ord1 Slice where liftCompare = genericLiftCompare
|
||||||
@ -234,7 +234,7 @@ instance Evaluatable Slice
|
|||||||
|
|
||||||
-- | A type switch statement in Go (e.g. `switch x.(type) { // cases }`).
|
-- | A type switch statement in Go (e.g. `switch x.(type) { // cases }`).
|
||||||
data TypeSwitch a = TypeSwitch { typeSwitchSubject :: !a, typeSwitchCases :: !a }
|
data TypeSwitch a = TypeSwitch { typeSwitchSubject :: !a, typeSwitchCases :: !a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 TypeSwitch where liftEq = genericLiftEq
|
instance Eq1 TypeSwitch where liftEq = genericLiftEq
|
||||||
instance Ord1 TypeSwitch where liftCompare = genericLiftCompare
|
instance Ord1 TypeSwitch where liftCompare = genericLiftCompare
|
||||||
@ -247,7 +247,7 @@ instance Evaluatable TypeSwitch
|
|||||||
|
|
||||||
-- | A type switch guard statement in a Go type switch statement (e.g. `switch i := x.(type) { // cases}`).
|
-- | A type switch guard statement in a Go type switch statement (e.g. `switch i := x.(type) { // cases}`).
|
||||||
newtype TypeSwitchGuard a = TypeSwitchGuard { typeSwitchGuardSubject :: a }
|
newtype TypeSwitchGuard a = TypeSwitchGuard { typeSwitchGuardSubject :: a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 TypeSwitchGuard where liftEq = genericLiftEq
|
instance Eq1 TypeSwitchGuard where liftEq = genericLiftEq
|
||||||
instance Ord1 TypeSwitchGuard where liftCompare = genericLiftCompare
|
instance Ord1 TypeSwitchGuard where liftCompare = genericLiftCompare
|
||||||
@ -260,7 +260,7 @@ instance Evaluatable TypeSwitchGuard
|
|||||||
|
|
||||||
-- | A receive statement in a Go select statement (e.g. `case value := <-channel` )
|
-- | A receive statement in a Go select statement (e.g. `case value := <-channel` )
|
||||||
data Receive a = Receive { receiveSubject :: !a, receiveExpression :: !a }
|
data Receive a = Receive { receiveSubject :: !a, receiveExpression :: !a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Receive where liftEq = genericLiftEq
|
instance Eq1 Receive where liftEq = genericLiftEq
|
||||||
instance Ord1 Receive where liftCompare = genericLiftCompare
|
instance Ord1 Receive where liftCompare = genericLiftCompare
|
||||||
@ -273,7 +273,7 @@ instance Evaluatable Receive
|
|||||||
|
|
||||||
-- | A receive operator unary expression in Go (e.g. `<-channel` )
|
-- | A receive operator unary expression in Go (e.g. `<-channel` )
|
||||||
newtype ReceiveOperator a = ReceiveOperator a
|
newtype ReceiveOperator a = ReceiveOperator a
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 ReceiveOperator where liftEq = genericLiftEq
|
instance Eq1 ReceiveOperator where liftEq = genericLiftEq
|
||||||
instance Ord1 ReceiveOperator where liftCompare = genericLiftCompare
|
instance Ord1 ReceiveOperator where liftCompare = genericLiftCompare
|
||||||
@ -286,7 +286,7 @@ instance Evaluatable ReceiveOperator
|
|||||||
|
|
||||||
-- | A field declaration in a Go struct type declaration.
|
-- | A field declaration in a Go struct type declaration.
|
||||||
data Field a = Field { fieldContext :: ![a], fieldName :: !a }
|
data Field a = Field { fieldContext :: ![a], fieldName :: !a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Field where liftEq = genericLiftEq
|
instance Eq1 Field where liftEq = genericLiftEq
|
||||||
instance Ord1 Field where liftCompare = genericLiftCompare
|
instance Ord1 Field where liftCompare = genericLiftCompare
|
||||||
@ -299,7 +299,7 @@ instance Evaluatable Field
|
|||||||
|
|
||||||
|
|
||||||
data Package a = Package { packageName :: !a, packageContents :: ![a] }
|
data Package a = Package { packageName :: !a, packageContents :: ![a] }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Package where liftEq = genericLiftEq
|
instance Eq1 Package where liftEq = genericLiftEq
|
||||||
instance Ord1 Package where liftCompare = genericLiftCompare
|
instance Ord1 Package where liftCompare = genericLiftCompare
|
||||||
@ -313,7 +313,7 @@ instance Evaluatable Package where
|
|||||||
|
|
||||||
-- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`).
|
-- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`).
|
||||||
data TypeAssertion a = TypeAssertion { typeAssertionSubject :: !a, typeAssertionType :: !a }
|
data TypeAssertion a = TypeAssertion { typeAssertionSubject :: !a, typeAssertionType :: !a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 TypeAssertion where liftEq = genericLiftEq
|
instance Eq1 TypeAssertion where liftEq = genericLiftEq
|
||||||
instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
|
instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
|
||||||
@ -326,7 +326,7 @@ instance Evaluatable TypeAssertion
|
|||||||
|
|
||||||
-- | A type conversion expression in Go (e.g. `T(x)` where `T` is a type and `x` is an expression that can be converted to type `T`).
|
-- | A type conversion expression in Go (e.g. `T(x)` where `T` is a type and `x` is an expression that can be converted to type `T`).
|
||||||
data TypeConversion a = TypeConversion { typeConversionType :: !a, typeConversionSubject :: !a }
|
data TypeConversion a = TypeConversion { typeConversionType :: !a, typeConversionSubject :: !a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 TypeConversion where liftEq = genericLiftEq
|
instance Eq1 TypeConversion where liftEq = genericLiftEq
|
||||||
instance Ord1 TypeConversion where liftCompare = genericLiftCompare
|
instance Ord1 TypeConversion where liftCompare = genericLiftCompare
|
||||||
@ -339,7 +339,7 @@ instance Evaluatable TypeConversion
|
|||||||
|
|
||||||
-- | Variadic arguments and parameters in Go (e.g. parameter: `param ...Type`, argument: `Type...`).
|
-- | Variadic arguments and parameters in Go (e.g. parameter: `param ...Type`, argument: `Type...`).
|
||||||
data Variadic a = Variadic { variadicContext :: [a], variadicIdentifier :: a }
|
data Variadic a = Variadic { variadicContext :: [a], variadicIdentifier :: a }
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Variadic where liftEq = genericLiftEq
|
instance Eq1 Variadic where liftEq = genericLiftEq
|
||||||
instance Ord1 Variadic where liftCompare = genericLiftCompare
|
instance Ord1 Variadic where liftCompare = genericLiftCompare
|
||||||
|
@ -8,7 +8,7 @@ import Diffing.Algorithm
|
|||||||
|
|
||||||
-- | A Bidirectional channel in Go (e.g. `chan`).
|
-- | A Bidirectional channel in Go (e.g. `chan`).
|
||||||
newtype BidirectionalChannel a = BidirectionalChannel a
|
newtype BidirectionalChannel a = BidirectionalChannel a
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 BidirectionalChannel where liftEq = genericLiftEq
|
instance Eq1 BidirectionalChannel where liftEq = genericLiftEq
|
||||||
instance Ord1 BidirectionalChannel where liftCompare = genericLiftCompare
|
instance Ord1 BidirectionalChannel where liftCompare = genericLiftCompare
|
||||||
@ -21,7 +21,7 @@ instance Evaluatable BidirectionalChannel
|
|||||||
|
|
||||||
-- | A Receive channel in Go (e.g. `<-chan`).
|
-- | A Receive channel in Go (e.g. `<-chan`).
|
||||||
newtype ReceiveChannel a = ReceiveChannel a
|
newtype ReceiveChannel a = ReceiveChannel a
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 ReceiveChannel where liftEq = genericLiftEq
|
instance Eq1 ReceiveChannel where liftEq = genericLiftEq
|
||||||
instance Ord1 ReceiveChannel where liftCompare = genericLiftCompare
|
instance Ord1 ReceiveChannel where liftCompare = genericLiftCompare
|
||||||
@ -34,7 +34,7 @@ instance Evaluatable ReceiveChannel
|
|||||||
|
|
||||||
-- | A Send channel in Go (e.g. `chan<-`).
|
-- | A Send channel in Go (e.g. `chan<-`).
|
||||||
newtype SendChannel a = SendChannel a
|
newtype SendChannel a = SendChannel a
|
||||||
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, FreeVariables1, Declarations1, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 SendChannel where liftEq = genericLiftEq
|
instance Eq1 SendChannel where liftEq = genericLiftEq
|
||||||
instance Ord1 SendChannel where liftCompare = genericLiftCompare
|
instance Ord1 SendChannel where liftCompare = genericLiftCompare
|
||||||
|
@ -11,7 +11,7 @@ data Module a = Module { moduleIdentifier :: !a
|
|||||||
, moduleExports :: ![a]
|
, moduleExports :: ![a]
|
||||||
, moduleStatements :: !a
|
, moduleStatements :: !a
|
||||||
}
|
}
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Module where liftEq = genericLiftEq
|
instance Eq1 Module where liftEq = genericLiftEq
|
||||||
instance Ord1 Module where liftCompare = genericLiftCompare
|
instance Ord1 Module where liftCompare = genericLiftCompare
|
||||||
|
@ -7,7 +7,7 @@ import Data.JSON.Fields
|
|||||||
import Diffing.Algorithm
|
import Diffing.Algorithm
|
||||||
|
|
||||||
newtype Document a = Document [a]
|
newtype Document a = Document [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Document
|
instance ToJSONFields1 Document
|
||||||
|
|
||||||
@ -19,7 +19,7 @@ instance Show1 Document where liftShowsPrec = genericLiftShowsPrec
|
|||||||
-- Block elements
|
-- Block elements
|
||||||
|
|
||||||
newtype Paragraph a = Paragraph [a]
|
newtype Paragraph a = Paragraph [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Paragraph
|
instance ToJSONFields1 Paragraph
|
||||||
|
|
||||||
@ -28,7 +28,7 @@ instance Ord1 Paragraph where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Paragraph where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Paragraph where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
data Heading a = Heading { headingLevel :: Int, headingContent :: [a], sectionContent :: [a] }
|
data Heading a = Heading { headingLevel :: Int, headingContent :: [a], sectionContent :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Heading
|
instance ToJSONFields1 Heading
|
||||||
|
|
||||||
@ -37,7 +37,7 @@ instance Ord1 Heading where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Heading where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Heading where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
newtype UnorderedList a = UnorderedList [a]
|
newtype UnorderedList a = UnorderedList [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 UnorderedList
|
instance ToJSONFields1 UnorderedList
|
||||||
|
|
||||||
@ -48,7 +48,7 @@ instance Show1 UnorderedList where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 OrderedList
|
instance ToJSONFields1 OrderedList
|
||||||
|
|
||||||
newtype OrderedList a = OrderedList [a]
|
newtype OrderedList a = OrderedList [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 OrderedList where liftEq = genericLiftEq
|
instance Eq1 OrderedList where liftEq = genericLiftEq
|
||||||
instance Ord1 OrderedList where liftCompare = genericLiftCompare
|
instance Ord1 OrderedList where liftCompare = genericLiftCompare
|
||||||
@ -57,7 +57,7 @@ instance Show1 OrderedList where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 BlockQuote
|
instance ToJSONFields1 BlockQuote
|
||||||
|
|
||||||
newtype BlockQuote a = BlockQuote [a]
|
newtype BlockQuote a = BlockQuote [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 BlockQuote where liftEq = genericLiftEq
|
instance Eq1 BlockQuote where liftEq = genericLiftEq
|
||||||
instance Ord1 BlockQuote where liftCompare = genericLiftCompare
|
instance Ord1 BlockQuote where liftCompare = genericLiftCompare
|
||||||
@ -66,7 +66,7 @@ instance Show1 BlockQuote where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 ThematicBreak
|
instance ToJSONFields1 ThematicBreak
|
||||||
|
|
||||||
data ThematicBreak a = ThematicBreak
|
data ThematicBreak a = ThematicBreak
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 ThematicBreak where liftEq = genericLiftEq
|
instance Eq1 ThematicBreak where liftEq = genericLiftEq
|
||||||
instance Ord1 ThematicBreak where liftCompare = genericLiftCompare
|
instance Ord1 ThematicBreak where liftCompare = genericLiftCompare
|
||||||
@ -76,14 +76,14 @@ instance ToJSONFields1 HTMLBlock where
|
|||||||
toJSONFields1 (HTMLBlock b) = noChildren [ "asString" .= unpack b ]
|
toJSONFields1 (HTMLBlock b) = noChildren [ "asString" .= unpack b ]
|
||||||
|
|
||||||
newtype HTMLBlock a = HTMLBlock ByteString
|
newtype HTMLBlock a = HTMLBlock ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 HTMLBlock where liftEq = genericLiftEq
|
instance Eq1 HTMLBlock where liftEq = genericLiftEq
|
||||||
instance Ord1 HTMLBlock where liftCompare = genericLiftCompare
|
instance Ord1 HTMLBlock where liftCompare = genericLiftCompare
|
||||||
instance Show1 HTMLBlock where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 HTMLBlock where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
newtype Table a = Table [a]
|
newtype Table a = Table [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Table
|
instance ToJSONFields1 Table
|
||||||
|
|
||||||
@ -92,7 +92,7 @@ instance Ord1 Table where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Table where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Table where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
newtype TableRow a = TableRow [a]
|
newtype TableRow a = TableRow [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 TableRow
|
instance ToJSONFields1 TableRow
|
||||||
|
|
||||||
@ -101,7 +101,7 @@ instance Ord1 TableRow where liftCompare = genericLiftCompare
|
|||||||
instance Show1 TableRow where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 TableRow where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
newtype TableCell a = TableCell [a]
|
newtype TableCell a = TableCell [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 TableCell
|
instance ToJSONFields1 TableCell
|
||||||
|
|
||||||
@ -113,7 +113,7 @@ instance Show1 TableCell where liftShowsPrec = genericLiftShowsPrec
|
|||||||
-- Inline elements
|
-- Inline elements
|
||||||
|
|
||||||
newtype Strong a = Strong [a]
|
newtype Strong a = Strong [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Strong
|
instance ToJSONFields1 Strong
|
||||||
|
|
||||||
@ -122,7 +122,7 @@ instance Ord1 Strong where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Strong where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Strong where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
newtype Emphasis a = Emphasis [a]
|
newtype Emphasis a = Emphasis [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Emphasis
|
instance ToJSONFields1 Emphasis
|
||||||
|
|
||||||
@ -131,7 +131,7 @@ instance Ord1 Emphasis where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Emphasis where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Emphasis where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
newtype Text a = Text ByteString
|
newtype Text a = Text ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Text where
|
instance ToJSONFields1 Text where
|
||||||
toJSONFields1 (Text s) = noChildren ["asString" .= unpack s ]
|
toJSONFields1 (Text s) = noChildren ["asString" .= unpack s ]
|
||||||
@ -141,7 +141,7 @@ instance Ord1 Text where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Text where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Text where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
data Link a = Link { linkURL :: ByteString, linkTitle :: Maybe ByteString }
|
data Link a = Link { linkURL :: ByteString, linkTitle :: Maybe ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
-- TODO: Better ToJSONFields1 instance
|
-- TODO: Better ToJSONFields1 instance
|
||||||
instance ToJSONFields1 Link
|
instance ToJSONFields1 Link
|
||||||
@ -151,7 +151,7 @@ instance Ord1 Link where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Link where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Link where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
data Image a = Image { imageURL :: ByteString, imageTitle :: Maybe ByteString }
|
data Image a = Image { imageURL :: ByteString, imageTitle :: Maybe ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
-- TODO: Better ToJSONFields1 instance
|
-- TODO: Better ToJSONFields1 instance
|
||||||
instance ToJSONFields1 Image
|
instance ToJSONFields1 Image
|
||||||
@ -161,7 +161,7 @@ instance Ord1 Image where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Image where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Image where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
data Code a = Code { codeLanguage :: Maybe ByteString, codeContent :: ByteString }
|
data Code a = Code { codeLanguage :: Maybe ByteString, codeContent :: ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
-- TODO: Better ToJSONFields1 instance
|
-- TODO: Better ToJSONFields1 instance
|
||||||
instance ToJSONFields1 Code
|
instance ToJSONFields1 Code
|
||||||
@ -171,7 +171,7 @@ instance Ord1 Code where liftCompare = genericLiftCompare
|
|||||||
instance Show1 Code where liftShowsPrec = genericLiftShowsPrec
|
instance Show1 Code where liftShowsPrec = genericLiftShowsPrec
|
||||||
|
|
||||||
data LineBreak a = LineBreak
|
data LineBreak a = LineBreak
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 LineBreak
|
instance ToJSONFields1 LineBreak
|
||||||
|
|
||||||
@ -182,7 +182,7 @@ instance Show1 LineBreak where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance ToJSONFields1 Strikethrough
|
instance ToJSONFields1 Strikethrough
|
||||||
|
|
||||||
newtype Strikethrough a = Strikethrough [a]
|
newtype Strikethrough a = Strikethrough [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Strikethrough where liftEq = genericLiftEq
|
instance Eq1 Strikethrough where liftEq = genericLiftEq
|
||||||
instance Ord1 Strikethrough where liftCompare = genericLiftCompare
|
instance Ord1 Strikethrough where liftCompare = genericLiftCompare
|
||||||
|
@ -12,7 +12,7 @@ import Prelude hiding (fail)
|
|||||||
import Prologue hiding (Text)
|
import Prologue hiding (Text)
|
||||||
|
|
||||||
newtype Text a = Text ByteString
|
newtype Text a = Text ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Text where
|
instance ToJSONFields1 Text where
|
||||||
toJSONFields1 (Text t) = noChildren ["asString" .= BC.unpack t]
|
toJSONFields1 (Text t) = noChildren ["asString" .= BC.unpack t]
|
||||||
@ -24,7 +24,7 @@ instance Evaluatable Text
|
|||||||
|
|
||||||
|
|
||||||
newtype VariableName a = VariableName a
|
newtype VariableName a = VariableName a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 VariableName
|
instance ToJSONFields1 VariableName
|
||||||
|
|
||||||
@ -41,42 +41,40 @@ instance Evaluatable VariableName
|
|||||||
-- file, the complete contents of the included file are treated as though it
|
-- file, the complete contents of the included file are treated as though it
|
||||||
-- were defined inside that function.
|
-- were defined inside that function.
|
||||||
|
|
||||||
resolvePHPName :: Members '[ Modules location value
|
resolvePHPName :: ( Member (Modules address value) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
] effects
|
)
|
||||||
=> ByteString
|
=> ByteString
|
||||||
-> Evaluator location value effects ModulePath
|
-> Evaluator address value effects ModulePath
|
||||||
resolvePHPName n = do
|
resolvePHPName n = do
|
||||||
modulePath <- resolve [name]
|
modulePath <- resolve [name]
|
||||||
maybe (throwResumable $ NotFoundError name [name] Language.PHP) pure modulePath
|
maybe (throwResumable $ NotFoundError name [name] Language.PHP) pure modulePath
|
||||||
where name = toName n
|
where name = toName n
|
||||||
toName = BC.unpack . dropRelativePrefix . stripQuotes
|
toName = BC.unpack . dropRelativePrefix . stripQuotes
|
||||||
|
|
||||||
include :: ( AbstractValue location value effects
|
include :: ( AbstractValue address value effects
|
||||||
, Members '[ Allocator location value
|
, Member (Allocator address value) effects
|
||||||
, Modules location value
|
, Member (Modules address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
, Resumable (EnvironmentError value)
|
, Member (Resumable (EnvironmentError address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Exports location)
|
, Member (State (Exports address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
, Member Trace effects
|
||||||
, Trace
|
|
||||||
] effects
|
|
||||||
)
|
)
|
||||||
=> Subterm term (Evaluator location value effects (ValueRef value))
|
=> Subterm term (Evaluator address value effects (ValueRef value))
|
||||||
-> (ModulePath -> Evaluator location value effects (Maybe (Environment location, value)))
|
-> (ModulePath -> Evaluator address value effects (Maybe (Environment address, value)))
|
||||||
-> Evaluator location value effects (ValueRef value)
|
-> Evaluator address value effects (ValueRef value)
|
||||||
include pathTerm f = do
|
include pathTerm f = do
|
||||||
name <- subtermValue pathTerm >>= asString
|
name <- subtermValue pathTerm >>= asString
|
||||||
path <- resolvePHPName name
|
path <- resolvePHPName name
|
||||||
traceResolve name path
|
traceResolve name path
|
||||||
(importedEnv, v) <- isolate (f path) >>= maybeM ((,) emptyEnv <$> unit)
|
(importedEnv, v) <- isolate (f path) >>= maybeM (pure (emptyEnv, unit))
|
||||||
modifyEnv (mergeEnvs importedEnv)
|
bindAll importedEnv
|
||||||
pure (Rval v)
|
pure (Rval v)
|
||||||
|
|
||||||
newtype Require a = Require a
|
newtype Require a = Require a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Require where liftEq = genericLiftEq
|
instance Eq1 Require where liftEq = genericLiftEq
|
||||||
instance Ord1 Require where liftCompare = genericLiftCompare
|
instance Ord1 Require where liftCompare = genericLiftCompare
|
||||||
@ -89,7 +87,7 @@ instance Evaluatable Require where
|
|||||||
|
|
||||||
|
|
||||||
newtype RequireOnce a = RequireOnce a
|
newtype RequireOnce a = RequireOnce a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 RequireOnce where liftEq = genericLiftEq
|
instance Eq1 RequireOnce where liftEq = genericLiftEq
|
||||||
instance Ord1 RequireOnce where liftCompare = genericLiftCompare
|
instance Ord1 RequireOnce where liftCompare = genericLiftCompare
|
||||||
@ -102,7 +100,7 @@ instance Evaluatable RequireOnce where
|
|||||||
|
|
||||||
|
|
||||||
newtype Include a = Include a
|
newtype Include a = Include a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Include where liftEq = genericLiftEq
|
instance Eq1 Include where liftEq = genericLiftEq
|
||||||
instance Ord1 Include where liftCompare = genericLiftCompare
|
instance Ord1 Include where liftCompare = genericLiftCompare
|
||||||
@ -115,7 +113,7 @@ instance Evaluatable Include where
|
|||||||
|
|
||||||
|
|
||||||
newtype IncludeOnce a = IncludeOnce a
|
newtype IncludeOnce a = IncludeOnce a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 IncludeOnce where liftEq = genericLiftEq
|
instance Eq1 IncludeOnce where liftEq = genericLiftEq
|
||||||
instance Ord1 IncludeOnce where liftCompare = genericLiftCompare
|
instance Ord1 IncludeOnce where liftCompare = genericLiftCompare
|
||||||
@ -128,7 +126,7 @@ instance Evaluatable IncludeOnce where
|
|||||||
|
|
||||||
|
|
||||||
newtype ArrayElement a = ArrayElement a
|
newtype ArrayElement a = ArrayElement a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ArrayElement
|
instance ToJSONFields1 ArrayElement
|
||||||
|
|
||||||
@ -138,7 +136,7 @@ instance Show1 ArrayElement where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ArrayElement
|
instance Evaluatable ArrayElement
|
||||||
|
|
||||||
newtype GlobalDeclaration a = GlobalDeclaration [a]
|
newtype GlobalDeclaration a = GlobalDeclaration [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 GlobalDeclaration
|
instance ToJSONFields1 GlobalDeclaration
|
||||||
|
|
||||||
@ -148,7 +146,7 @@ instance Show1 GlobalDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable GlobalDeclaration
|
instance Evaluatable GlobalDeclaration
|
||||||
|
|
||||||
newtype SimpleVariable a = SimpleVariable a
|
newtype SimpleVariable a = SimpleVariable a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 SimpleVariable
|
instance ToJSONFields1 SimpleVariable
|
||||||
|
|
||||||
@ -160,7 +158,7 @@ instance Evaluatable SimpleVariable
|
|||||||
|
|
||||||
-- | TODO: Unify with TypeScript's PredefinedType
|
-- | TODO: Unify with TypeScript's PredefinedType
|
||||||
newtype CastType a = CastType { _castType :: ByteString }
|
newtype CastType a = CastType { _castType :: ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 CastType
|
instance ToJSONFields1 CastType
|
||||||
|
|
||||||
@ -170,7 +168,7 @@ instance Show1 CastType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable CastType
|
instance Evaluatable CastType
|
||||||
|
|
||||||
newtype ErrorControl a = ErrorControl a
|
newtype ErrorControl a = ErrorControl a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ErrorControl
|
instance ToJSONFields1 ErrorControl
|
||||||
|
|
||||||
@ -180,7 +178,7 @@ instance Show1 ErrorControl where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ErrorControl
|
instance Evaluatable ErrorControl
|
||||||
|
|
||||||
newtype Clone a = Clone a
|
newtype Clone a = Clone a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Clone
|
instance ToJSONFields1 Clone
|
||||||
|
|
||||||
@ -190,7 +188,7 @@ instance Show1 Clone where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Clone
|
instance Evaluatable Clone
|
||||||
|
|
||||||
newtype ShellCommand a = ShellCommand ByteString
|
newtype ShellCommand a = ShellCommand ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ShellCommand
|
instance ToJSONFields1 ShellCommand
|
||||||
|
|
||||||
@ -201,7 +199,7 @@ instance Evaluatable ShellCommand
|
|||||||
|
|
||||||
-- | TODO: Combine with TypeScript update expression.
|
-- | TODO: Combine with TypeScript update expression.
|
||||||
newtype Update a = Update { _updateSubject :: a }
|
newtype Update a = Update { _updateSubject :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Update
|
instance ToJSONFields1 Update
|
||||||
|
|
||||||
@ -211,7 +209,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Update
|
instance Evaluatable Update
|
||||||
|
|
||||||
newtype NewVariable a = NewVariable [a]
|
newtype NewVariable a = NewVariable [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 NewVariable
|
instance ToJSONFields1 NewVariable
|
||||||
|
|
||||||
@ -221,7 +219,7 @@ instance Show1 NewVariable where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable NewVariable
|
instance Evaluatable NewVariable
|
||||||
|
|
||||||
newtype RelativeScope a = RelativeScope ByteString
|
newtype RelativeScope a = RelativeScope ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 RelativeScope
|
instance ToJSONFields1 RelativeScope
|
||||||
|
|
||||||
@ -231,7 +229,7 @@ instance Show1 RelativeScope where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable RelativeScope
|
instance Evaluatable RelativeScope
|
||||||
|
|
||||||
data QualifiedName a = QualifiedName !a !a
|
data QualifiedName a = QualifiedName !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 QualifiedName
|
instance ToJSONFields1 QualifiedName
|
||||||
|
|
||||||
@ -243,7 +241,7 @@ instance Evaluatable QualifiedName where
|
|||||||
eval (fmap subtermValue -> QualifiedName name iden) = Rval <$> evaluateInScopedEnv name iden
|
eval (fmap subtermValue -> QualifiedName name iden) = Rval <$> evaluateInScopedEnv name iden
|
||||||
|
|
||||||
newtype NamespaceName a = NamespaceName (NonEmpty a)
|
newtype NamespaceName a = NamespaceName (NonEmpty a)
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 NamespaceName
|
instance ToJSONFields1 NamespaceName
|
||||||
|
|
||||||
@ -256,7 +254,7 @@ instance Evaluatable NamespaceName where
|
|||||||
eval (NamespaceName xs) = Rval <$> foldl1 evaluateInScopedEnv (fmap subtermValue xs)
|
eval (NamespaceName xs) = Rval <$> foldl1 evaluateInScopedEnv (fmap subtermValue xs)
|
||||||
|
|
||||||
newtype ConstDeclaration a = ConstDeclaration [a]
|
newtype ConstDeclaration a = ConstDeclaration [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ConstDeclaration
|
instance ToJSONFields1 ConstDeclaration
|
||||||
|
|
||||||
@ -266,7 +264,7 @@ instance Show1 ConstDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ConstDeclaration
|
instance Evaluatable ConstDeclaration
|
||||||
|
|
||||||
data ClassConstDeclaration a = ClassConstDeclaration a [a]
|
data ClassConstDeclaration a = ClassConstDeclaration a [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ClassConstDeclaration
|
instance ToJSONFields1 ClassConstDeclaration
|
||||||
|
|
||||||
@ -276,7 +274,7 @@ instance Show1 ClassConstDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ClassConstDeclaration
|
instance Evaluatable ClassConstDeclaration
|
||||||
|
|
||||||
newtype ClassInterfaceClause a = ClassInterfaceClause [a]
|
newtype ClassInterfaceClause a = ClassInterfaceClause [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ClassInterfaceClause
|
instance ToJSONFields1 ClassInterfaceClause
|
||||||
|
|
||||||
@ -286,7 +284,7 @@ instance Show1 ClassInterfaceClause where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ClassInterfaceClause
|
instance Evaluatable ClassInterfaceClause
|
||||||
|
|
||||||
newtype ClassBaseClause a = ClassBaseClause a
|
newtype ClassBaseClause a = ClassBaseClause a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ClassBaseClause
|
instance ToJSONFields1 ClassBaseClause
|
||||||
|
|
||||||
@ -297,7 +295,7 @@ instance Evaluatable ClassBaseClause
|
|||||||
|
|
||||||
|
|
||||||
newtype UseClause a = UseClause [a]
|
newtype UseClause a = UseClause [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 UseClause
|
instance ToJSONFields1 UseClause
|
||||||
|
|
||||||
@ -307,7 +305,7 @@ instance Show1 UseClause where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable UseClause
|
instance Evaluatable UseClause
|
||||||
|
|
||||||
newtype ReturnType a = ReturnType a
|
newtype ReturnType a = ReturnType a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ReturnType
|
instance ToJSONFields1 ReturnType
|
||||||
|
|
||||||
@ -317,7 +315,7 @@ instance Show1 ReturnType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ReturnType
|
instance Evaluatable ReturnType
|
||||||
|
|
||||||
newtype TypeDeclaration a = TypeDeclaration a
|
newtype TypeDeclaration a = TypeDeclaration a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 TypeDeclaration
|
instance ToJSONFields1 TypeDeclaration
|
||||||
|
|
||||||
@ -327,7 +325,7 @@ instance Show1 TypeDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TypeDeclaration
|
instance Evaluatable TypeDeclaration
|
||||||
|
|
||||||
newtype BaseTypeDeclaration a = BaseTypeDeclaration a
|
newtype BaseTypeDeclaration a = BaseTypeDeclaration a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 BaseTypeDeclaration
|
instance ToJSONFields1 BaseTypeDeclaration
|
||||||
|
|
||||||
@ -337,7 +335,7 @@ instance Show1 BaseTypeDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable BaseTypeDeclaration
|
instance Evaluatable BaseTypeDeclaration
|
||||||
|
|
||||||
newtype ScalarType a = ScalarType ByteString
|
newtype ScalarType a = ScalarType ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ScalarType
|
instance ToJSONFields1 ScalarType
|
||||||
|
|
||||||
@ -347,7 +345,7 @@ instance Show1 ScalarType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ScalarType
|
instance Evaluatable ScalarType
|
||||||
|
|
||||||
newtype EmptyIntrinsic a = EmptyIntrinsic a
|
newtype EmptyIntrinsic a = EmptyIntrinsic a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 EmptyIntrinsic
|
instance ToJSONFields1 EmptyIntrinsic
|
||||||
|
|
||||||
@ -357,7 +355,7 @@ instance Show1 EmptyIntrinsic where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable EmptyIntrinsic
|
instance Evaluatable EmptyIntrinsic
|
||||||
|
|
||||||
newtype ExitIntrinsic a = ExitIntrinsic a
|
newtype ExitIntrinsic a = ExitIntrinsic a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ExitIntrinsic
|
instance ToJSONFields1 ExitIntrinsic
|
||||||
|
|
||||||
@ -367,7 +365,7 @@ instance Show1 ExitIntrinsic where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ExitIntrinsic
|
instance Evaluatable ExitIntrinsic
|
||||||
|
|
||||||
newtype IssetIntrinsic a = IssetIntrinsic a
|
newtype IssetIntrinsic a = IssetIntrinsic a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 IssetIntrinsic
|
instance ToJSONFields1 IssetIntrinsic
|
||||||
|
|
||||||
@ -377,7 +375,7 @@ instance Show1 IssetIntrinsic where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable IssetIntrinsic
|
instance Evaluatable IssetIntrinsic
|
||||||
|
|
||||||
newtype EvalIntrinsic a = EvalIntrinsic a
|
newtype EvalIntrinsic a = EvalIntrinsic a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 EvalIntrinsic
|
instance ToJSONFields1 EvalIntrinsic
|
||||||
|
|
||||||
@ -387,7 +385,7 @@ instance Show1 EvalIntrinsic where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable EvalIntrinsic
|
instance Evaluatable EvalIntrinsic
|
||||||
|
|
||||||
newtype PrintIntrinsic a = PrintIntrinsic a
|
newtype PrintIntrinsic a = PrintIntrinsic a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 PrintIntrinsic
|
instance ToJSONFields1 PrintIntrinsic
|
||||||
|
|
||||||
@ -397,7 +395,7 @@ instance Show1 PrintIntrinsic where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable PrintIntrinsic
|
instance Evaluatable PrintIntrinsic
|
||||||
|
|
||||||
newtype NamespaceAliasingClause a = NamespaceAliasingClause a
|
newtype NamespaceAliasingClause a = NamespaceAliasingClause a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 NamespaceAliasingClause
|
instance ToJSONFields1 NamespaceAliasingClause
|
||||||
|
|
||||||
@ -407,7 +405,7 @@ instance Show1 NamespaceAliasingClause where liftShowsPrec = genericLiftShowsPre
|
|||||||
instance Evaluatable NamespaceAliasingClause
|
instance Evaluatable NamespaceAliasingClause
|
||||||
|
|
||||||
newtype NamespaceUseDeclaration a = NamespaceUseDeclaration [a]
|
newtype NamespaceUseDeclaration a = NamespaceUseDeclaration [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 NamespaceUseDeclaration
|
instance ToJSONFields1 NamespaceUseDeclaration
|
||||||
|
|
||||||
@ -417,7 +415,7 @@ instance Show1 NamespaceUseDeclaration where liftShowsPrec = genericLiftShowsPre
|
|||||||
instance Evaluatable NamespaceUseDeclaration
|
instance Evaluatable NamespaceUseDeclaration
|
||||||
|
|
||||||
newtype NamespaceUseClause a = NamespaceUseClause [a]
|
newtype NamespaceUseClause a = NamespaceUseClause [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 NamespaceUseClause
|
instance ToJSONFields1 NamespaceUseClause
|
||||||
|
|
||||||
@ -427,7 +425,7 @@ instance Show1 NamespaceUseClause where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable NamespaceUseClause
|
instance Evaluatable NamespaceUseClause
|
||||||
|
|
||||||
newtype NamespaceUseGroupClause a = NamespaceUseGroupClause [a]
|
newtype NamespaceUseGroupClause a = NamespaceUseGroupClause [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 NamespaceUseGroupClause
|
instance ToJSONFields1 NamespaceUseGroupClause
|
||||||
|
|
||||||
@ -437,7 +435,7 @@ instance Show1 NamespaceUseGroupClause where liftShowsPrec = genericLiftShowsPre
|
|||||||
instance Evaluatable NamespaceUseGroupClause
|
instance Evaluatable NamespaceUseGroupClause
|
||||||
|
|
||||||
data Namespace a = Namespace { namespaceName :: a, namespaceBody :: a }
|
data Namespace a = Namespace { namespaceName :: a, namespaceBody :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance Eq1 Namespace where liftEq = genericLiftEq
|
instance Eq1 Namespace where liftEq = genericLiftEq
|
||||||
instance Ord1 Namespace where liftCompare = genericLiftCompare
|
instance Ord1 Namespace where liftCompare = genericLiftCompare
|
||||||
@ -458,7 +456,7 @@ instance Evaluatable Namespace where
|
|||||||
go xs <* makeNamespace name addr Nothing
|
go xs <* makeNamespace name addr Nothing
|
||||||
|
|
||||||
data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] }
|
data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 TraitDeclaration
|
instance ToJSONFields1 TraitDeclaration
|
||||||
|
|
||||||
@ -468,7 +466,7 @@ instance Show1 TraitDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TraitDeclaration
|
instance Evaluatable TraitDeclaration
|
||||||
|
|
||||||
data AliasAs a = AliasAs { aliasAsName :: a, aliasAsModifier :: a, aliasAsClause :: a }
|
data AliasAs a = AliasAs { aliasAsName :: a, aliasAsModifier :: a, aliasAsClause :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 AliasAs
|
instance ToJSONFields1 AliasAs
|
||||||
|
|
||||||
@ -478,7 +476,7 @@ instance Show1 AliasAs where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable AliasAs
|
instance Evaluatable AliasAs
|
||||||
|
|
||||||
data InsteadOf a = InsteadOf a a
|
data InsteadOf a = InsteadOf a a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 InsteadOf
|
instance ToJSONFields1 InsteadOf
|
||||||
|
|
||||||
@ -488,7 +486,7 @@ instance Show1 InsteadOf where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable InsteadOf
|
instance Evaluatable InsteadOf
|
||||||
|
|
||||||
newtype TraitUseSpecification a = TraitUseSpecification [a]
|
newtype TraitUseSpecification a = TraitUseSpecification [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 TraitUseSpecification
|
instance ToJSONFields1 TraitUseSpecification
|
||||||
|
|
||||||
@ -498,7 +496,7 @@ instance Show1 TraitUseSpecification where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TraitUseSpecification
|
instance Evaluatable TraitUseSpecification
|
||||||
|
|
||||||
data TraitUseClause a = TraitUseClause [a] a
|
data TraitUseClause a = TraitUseClause [a] a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 TraitUseClause
|
instance ToJSONFields1 TraitUseClause
|
||||||
|
|
||||||
@ -508,7 +506,7 @@ instance Show1 TraitUseClause where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TraitUseClause
|
instance Evaluatable TraitUseClause
|
||||||
|
|
||||||
data DestructorDeclaration a = DestructorDeclaration [a] a
|
data DestructorDeclaration a = DestructorDeclaration [a] a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 DestructorDeclaration
|
instance ToJSONFields1 DestructorDeclaration
|
||||||
|
|
||||||
@ -518,7 +516,7 @@ instance Show1 DestructorDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable DestructorDeclaration
|
instance Evaluatable DestructorDeclaration
|
||||||
|
|
||||||
newtype Static a = Static ByteString
|
newtype Static a = Static ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Static
|
instance ToJSONFields1 Static
|
||||||
|
|
||||||
@ -528,7 +526,7 @@ instance Show1 Static where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Static
|
instance Evaluatable Static
|
||||||
|
|
||||||
newtype ClassModifier a = ClassModifier ByteString
|
newtype ClassModifier a = ClassModifier ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ClassModifier
|
instance ToJSONFields1 ClassModifier
|
||||||
|
|
||||||
@ -538,7 +536,7 @@ instance Show1 ClassModifier where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ClassModifier
|
instance Evaluatable ClassModifier
|
||||||
|
|
||||||
data ConstructorDeclaration a = ConstructorDeclaration [a] [a] a
|
data ConstructorDeclaration a = ConstructorDeclaration [a] [a] a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 ConstructorDeclaration
|
instance ToJSONFields1 ConstructorDeclaration
|
||||||
|
|
||||||
@ -548,7 +546,7 @@ instance Show1 ConstructorDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ConstructorDeclaration
|
instance Evaluatable ConstructorDeclaration
|
||||||
|
|
||||||
data PropertyDeclaration a = PropertyDeclaration a [a]
|
data PropertyDeclaration a = PropertyDeclaration a [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 PropertyDeclaration
|
instance ToJSONFields1 PropertyDeclaration
|
||||||
|
|
||||||
@ -558,7 +556,7 @@ instance Show1 PropertyDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable PropertyDeclaration
|
instance Evaluatable PropertyDeclaration
|
||||||
|
|
||||||
data PropertyModifier a = PropertyModifier a a
|
data PropertyModifier a = PropertyModifier a a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 PropertyModifier
|
instance ToJSONFields1 PropertyModifier
|
||||||
|
|
||||||
@ -568,7 +566,7 @@ instance Show1 PropertyModifier where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable PropertyModifier
|
instance Evaluatable PropertyModifier
|
||||||
|
|
||||||
data InterfaceDeclaration a = InterfaceDeclaration a a [a]
|
data InterfaceDeclaration a = InterfaceDeclaration a a [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 InterfaceDeclaration
|
instance ToJSONFields1 InterfaceDeclaration
|
||||||
|
|
||||||
@ -578,7 +576,7 @@ instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable InterfaceDeclaration
|
instance Evaluatable InterfaceDeclaration
|
||||||
|
|
||||||
newtype InterfaceBaseClause a = InterfaceBaseClause [a]
|
newtype InterfaceBaseClause a = InterfaceBaseClause [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 InterfaceBaseClause
|
instance ToJSONFields1 InterfaceBaseClause
|
||||||
|
|
||||||
@ -588,7 +586,7 @@ instance Show1 InterfaceBaseClause where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable InterfaceBaseClause
|
instance Evaluatable InterfaceBaseClause
|
||||||
|
|
||||||
newtype Echo a = Echo a
|
newtype Echo a = Echo a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Echo
|
instance ToJSONFields1 Echo
|
||||||
|
|
||||||
@ -598,7 +596,7 @@ instance Show1 Echo where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Echo
|
instance Evaluatable Echo
|
||||||
|
|
||||||
newtype Unset a = Unset a
|
newtype Unset a = Unset a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Unset
|
instance ToJSONFields1 Unset
|
||||||
|
|
||||||
@ -608,7 +606,7 @@ instance Show1 Unset where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Unset
|
instance Evaluatable Unset
|
||||||
|
|
||||||
data Declare a = Declare a a
|
data Declare a = Declare a a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 Declare
|
instance ToJSONFields1 Declare
|
||||||
|
|
||||||
@ -618,7 +616,7 @@ instance Show1 Declare where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Declare
|
instance Evaluatable Declare
|
||||||
|
|
||||||
newtype DeclareDirective a = DeclareDirective a
|
newtype DeclareDirective a = DeclareDirective a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 DeclareDirective
|
instance ToJSONFields1 DeclareDirective
|
||||||
|
|
||||||
@ -628,7 +626,7 @@ instance Show1 DeclareDirective where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable DeclareDirective
|
instance Evaluatable DeclareDirective
|
||||||
|
|
||||||
newtype LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a }
|
newtype LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, Declarations1, Generic1, Hashable1, Mergeable, Ord, Show, Traversable)
|
||||||
|
|
||||||
instance ToJSONFields1 LabeledStatement
|
instance ToJSONFields1 LabeledStatement
|
||||||
|
|
||||||
|
@ -4,7 +4,6 @@ module Language.Python.Syntax where
|
|||||||
import Data.Abstract.Environment as Env
|
import Data.Abstract.Environment as Env
|
||||||
import Data.Abstract.Evaluatable
|
import Data.Abstract.Evaluatable
|
||||||
import Data.Abstract.Module
|
import Data.Abstract.Module
|
||||||
import Data.Align.Generic
|
|
||||||
import qualified Data.ByteString.Char8 as BC
|
import qualified Data.ByteString.Char8 as BC
|
||||||
import Data.Functor.Classes.Generic
|
import Data.Functor.Classes.Generic
|
||||||
import Data.JSON.Fields
|
import Data.JSON.Fields
|
||||||
@ -52,13 +51,13 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (BC.unpack prefix) (J
|
|||||||
-- Subsequent imports of `parent.two` or `parent.three` will execute
|
-- Subsequent imports of `parent.two` or `parent.three` will execute
|
||||||
-- `parent/two/__init__.py` and
|
-- `parent/two/__init__.py` and
|
||||||
-- `parent/three/__init__.py` respectively.
|
-- `parent/three/__init__.py` respectively.
|
||||||
resolvePythonModules :: Members '[ Modules location value
|
resolvePythonModules :: ( Member (Modules address value) effects
|
||||||
, Reader ModuleInfo
|
, Member (Reader ModuleInfo) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
)
|
||||||
=> QualifiedName
|
=> QualifiedName
|
||||||
-> Evaluator location value effects (NonEmpty ModulePath)
|
-> Evaluator address value effects (NonEmpty ModulePath)
|
||||||
resolvePythonModules q = do
|
resolvePythonModules q = do
|
||||||
relRootDir <- rootDir q <$> currentModule
|
relRootDir <- rootDir q <$> currentModule
|
||||||
for (moduleNames q) $ \name -> do
|
for (moduleNames q) $ \name -> do
|
||||||
@ -89,7 +88,7 @@ resolvePythonModules q = do
|
|||||||
--
|
--
|
||||||
-- If the list of symbols is empty copy everything to the calling environment.
|
-- If the list of symbols is empty copy everything to the calling environment.
|
||||||
data Import a = Import { importFrom :: QualifiedName, importSymbols :: ![(Name, Name)] }
|
data Import a = Import { importFrom :: QualifiedName, importSymbols :: ![(Name, Name)] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Import
|
instance ToJSONFields1 Import
|
||||||
|
|
||||||
@ -118,8 +117,8 @@ instance Evaluatable Import where
|
|||||||
-- Last module path is the one we want to import
|
-- Last module path is the one we want to import
|
||||||
let path = NonEmpty.last modulePaths
|
let path = NonEmpty.last modulePaths
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||||
modifyEnv (mergeEnvs (select importedEnv))
|
bindAll (select importedEnv)
|
||||||
Rval <$> unit
|
pure (Rval unit)
|
||||||
where
|
where
|
||||||
select importedEnv
|
select importedEnv
|
||||||
| Prologue.null xs = importedEnv
|
| Prologue.null xs = importedEnv
|
||||||
@ -127,26 +126,24 @@ instance Evaluatable Import where
|
|||||||
|
|
||||||
|
|
||||||
-- Evaluate a qualified import
|
-- Evaluate a qualified import
|
||||||
evalQualifiedImport :: ( AbstractValue location value effects
|
evalQualifiedImport :: ( AbstractValue address value effects
|
||||||
, Members '[ Allocator location value
|
, Member (Allocator address value) effects
|
||||||
, Modules location value
|
, Member (Modules address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Exports location)
|
, Member (State (Exports address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
] effects
|
, Ord address
|
||||||
, Ord location
|
, Reducer.Reducer value (Cell address value)
|
||||||
, Reducer.Reducer value (Cell location value)
|
|
||||||
)
|
)
|
||||||
=> Name -> ModulePath -> Evaluator location value effects value
|
=> Name -> ModulePath -> Evaluator address value effects value
|
||||||
evalQualifiedImport name path = letrec' name $ \addr -> do
|
evalQualifiedImport name path = letrec' name $ \addr -> do
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||||
modifyEnv (mergeEnvs importedEnv)
|
bindAll importedEnv
|
||||||
void $ makeNamespace name addr Nothing
|
unit <$ makeNamespace name addr Nothing
|
||||||
unit
|
|
||||||
|
|
||||||
newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: QualifiedName }
|
newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: QualifiedName }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 QualifiedImport
|
instance ToJSONFields1 QualifiedImport
|
||||||
|
|
||||||
@ -170,7 +167,7 @@ instance Evaluatable QualifiedImport where
|
|||||||
makeNamespace name addr Nothing
|
makeNamespace name addr Nothing
|
||||||
|
|
||||||
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportFrom :: QualifiedName, qualifiedAliasedImportAlias :: !a }
|
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportFrom :: QualifiedName, qualifiedAliasedImportAlias :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 QualifiedAliasedImport
|
instance ToJSONFields1 QualifiedAliasedImport
|
||||||
|
|
||||||
@ -191,13 +188,12 @@ instance Evaluatable QualifiedAliasedImport where
|
|||||||
Rval <$> letrec' alias (\addr -> do
|
Rval <$> letrec' alias (\addr -> do
|
||||||
let path = NonEmpty.last modulePaths
|
let path = NonEmpty.last modulePaths
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
importedEnv <- maybe emptyEnv fst <$> isolate (require path)
|
||||||
modifyEnv (mergeEnvs importedEnv)
|
bindAll importedEnv
|
||||||
void $ makeNamespace alias addr Nothing
|
unit <$ makeNamespace alias addr Nothing)
|
||||||
unit)
|
|
||||||
|
|
||||||
-- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell)
|
-- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell)
|
||||||
data Ellipsis a = Ellipsis
|
data Ellipsis a = Ellipsis
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Ellipsis where liftEq = genericLiftEq
|
instance Eq1 Ellipsis where liftEq = genericLiftEq
|
||||||
instance Ord1 Ellipsis where liftCompare = genericLiftCompare
|
instance Ord1 Ellipsis where liftCompare = genericLiftCompare
|
||||||
@ -210,7 +206,7 @@ instance Evaluatable Ellipsis
|
|||||||
|
|
||||||
|
|
||||||
data Redirect a = Redirect !a !a
|
data Redirect a = Redirect !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Redirect where liftEq = genericLiftEq
|
instance Eq1 Redirect where liftEq = genericLiftEq
|
||||||
instance Ord1 Redirect where liftCompare = genericLiftCompare
|
instance Ord1 Redirect where liftCompare = genericLiftCompare
|
||||||
|
@ -17,11 +17,11 @@ import System.FilePath.Posix
|
|||||||
-- TODO: Fully sort out ruby require/load mechanics
|
-- TODO: Fully sort out ruby require/load mechanics
|
||||||
--
|
--
|
||||||
-- require "json"
|
-- require "json"
|
||||||
resolveRubyName :: Members '[ Modules location value
|
resolveRubyName :: ( Member (Modules address value) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
] effects
|
)
|
||||||
=> ByteString
|
=> ByteString
|
||||||
-> Evaluator location value effects M.ModulePath
|
-> Evaluator address value effects M.ModulePath
|
||||||
resolveRubyName name = do
|
resolveRubyName name = do
|
||||||
let name' = cleanNameOrPath name
|
let name' = cleanNameOrPath name
|
||||||
let paths = [name' <.> "rb"]
|
let paths = [name' <.> "rb"]
|
||||||
@ -29,11 +29,11 @@ resolveRubyName name = do
|
|||||||
maybe (throwResumable $ NotFoundError name' paths Language.Ruby) pure modulePath
|
maybe (throwResumable $ NotFoundError name' paths Language.Ruby) pure modulePath
|
||||||
|
|
||||||
-- load "/root/src/file.rb"
|
-- load "/root/src/file.rb"
|
||||||
resolveRubyPath :: Members '[ Modules location value
|
resolveRubyPath :: ( Member (Modules address value) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
] effects
|
)
|
||||||
=> ByteString
|
=> ByteString
|
||||||
-> Evaluator location value effects M.ModulePath
|
-> Evaluator address value effects M.ModulePath
|
||||||
resolveRubyPath path = do
|
resolveRubyPath path = do
|
||||||
let name' = cleanNameOrPath path
|
let name' = cleanNameOrPath path
|
||||||
modulePath <- resolve [name']
|
modulePath <- resolve [name']
|
||||||
@ -43,7 +43,7 @@ cleanNameOrPath :: ByteString -> String
|
|||||||
cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes
|
cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes
|
||||||
|
|
||||||
data Send a = Send { sendReceiver :: Maybe a, sendSelector :: Maybe a, sendArgs :: [a], sendBlock :: Maybe a }
|
data Send a = Send { sendReceiver :: Maybe a, sendSelector :: Maybe a, sendArgs :: [a], sendBlock :: Maybe a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Send where liftEq = genericLiftEq
|
instance Eq1 Send where liftEq = genericLiftEq
|
||||||
instance Ord1 Send where liftCompare = genericLiftCompare
|
instance Ord1 Send where liftCompare = genericLiftCompare
|
||||||
@ -60,7 +60,7 @@ instance Evaluatable Send where
|
|||||||
Rval <$> call func (map subtermValue sendArgs) -- TODO pass through sendBlock
|
Rval <$> call func (map subtermValue sendArgs) -- TODO pass through sendBlock
|
||||||
|
|
||||||
data Require a = Require { requireRelative :: Bool, requirePath :: !a }
|
data Require a = Require { requireRelative :: Bool, requirePath :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Require where liftEq = genericLiftEq
|
instance Eq1 Require where liftEq = genericLiftEq
|
||||||
instance Ord1 Require where liftCompare = genericLiftCompare
|
instance Ord1 Require where liftCompare = genericLiftCompare
|
||||||
@ -74,23 +74,23 @@ instance Evaluatable Require where
|
|||||||
path <- resolveRubyName name
|
path <- resolveRubyName name
|
||||||
traceResolve name path
|
traceResolve name path
|
||||||
(importedEnv, v) <- isolate (doRequire path)
|
(importedEnv, v) <- isolate (doRequire path)
|
||||||
modifyEnv (`mergeNewer` importedEnv)
|
bindAll importedEnv
|
||||||
pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
|
pure (Rval v) -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require
|
||||||
|
|
||||||
doRequire :: ( AbstractValue location value effects
|
doRequire :: ( AbstractValue address value effects
|
||||||
, Member (Modules location value) effects
|
, Member (Modules address value) effects
|
||||||
)
|
)
|
||||||
=> M.ModulePath
|
=> M.ModulePath
|
||||||
-> Evaluator location value effects (Environment location, value)
|
-> Evaluator address value effects (Environment address, value)
|
||||||
doRequire path = do
|
doRequire path = do
|
||||||
result <- join <$> lookupModule path
|
result <- join <$> lookupModule path
|
||||||
case result of
|
case result of
|
||||||
Nothing -> (,) . maybe emptyEnv fst <$> load path <*> boolean True
|
Nothing -> (,) . maybe emptyEnv fst <$> load path <*> pure (boolean True)
|
||||||
Just (env, _) -> (,) env <$> boolean False
|
Just (env, _) -> pure (env, boolean False)
|
||||||
|
|
||||||
|
|
||||||
newtype Load a = Load { loadArgs :: [a] }
|
newtype Load a = Load { loadArgs :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Load where liftEq = genericLiftEq
|
instance Eq1 Load where liftEq = genericLiftEq
|
||||||
instance Ord1 Load where liftCompare = genericLiftCompare
|
instance Ord1 Load where liftCompare = genericLiftCompare
|
||||||
@ -108,28 +108,27 @@ instance Evaluatable Load where
|
|||||||
Rval <$> doLoad path shouldWrap
|
Rval <$> doLoad path shouldWrap
|
||||||
eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required")
|
eval (Load _) = raiseEff (fail "invalid argument supplied to load, path is required")
|
||||||
|
|
||||||
doLoad :: ( AbstractValue location value effects
|
doLoad :: ( AbstractValue address value effects
|
||||||
, Members '[ Modules location value
|
, Member (Modules address value) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Exports location)
|
, Member (State (Exports address)) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
|
||||||
)
|
)
|
||||||
=> ByteString
|
=> ByteString
|
||||||
-> Bool
|
-> Bool
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
doLoad path shouldWrap = do
|
doLoad path shouldWrap = do
|
||||||
path' <- resolveRubyPath path
|
path' <- resolveRubyPath path
|
||||||
traceResolve path path'
|
traceResolve path path'
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (load path')
|
importedEnv <- maybe emptyEnv fst <$> isolate (load path')
|
||||||
unless shouldWrap $ modifyEnv (mergeEnvs importedEnv)
|
unless shouldWrap $ bindAll importedEnv
|
||||||
boolean Prelude.True -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load
|
pure (boolean Prelude.True) -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load
|
||||||
|
|
||||||
-- TODO: autoload
|
-- TODO: autoload
|
||||||
|
|
||||||
data Class a = Class { classIdentifier :: !a, classSuperClass :: !(Maybe a), classBody :: !a }
|
data Class a = Class { classIdentifier :: !a, classSuperClass :: !(Maybe a), classBody :: !a }
|
||||||
deriving (Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Class
|
instance ToJSONFields1 Class
|
||||||
|
|
||||||
@ -148,7 +147,7 @@ instance Evaluatable Class where
|
|||||||
subtermValue classBody <* makeNamespace name addr super)
|
subtermValue classBody <* makeNamespace name addr super)
|
||||||
|
|
||||||
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
|
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Module where liftEq = genericLiftEq
|
instance Eq1 Module where liftEq = genericLiftEq
|
||||||
instance Ord1 Module where liftCompare = genericLiftCompare
|
instance Ord1 Module where liftCompare = genericLiftCompare
|
||||||
@ -165,7 +164,7 @@ instance Evaluatable Module where
|
|||||||
data LowPrecedenceBoolean a
|
data LowPrecedenceBoolean a
|
||||||
= LowAnd !a !a
|
= LowAnd !a !a
|
||||||
| LowOr !a !a
|
| LowOr !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 LowPrecedenceBoolean
|
instance ToJSONFields1 LowPrecedenceBoolean
|
||||||
|
|
||||||
|
@ -37,15 +37,15 @@ toName = name . BC.pack . unPath
|
|||||||
--
|
--
|
||||||
-- NB: TypeScript has a couple of different strategies, but the main one (and the
|
-- NB: TypeScript has a couple of different strategies, but the main one (and the
|
||||||
-- only one we support) mimics Node.js.
|
-- only one we support) mimics Node.js.
|
||||||
resolveWithNodejsStrategy :: Members '[ Modules location value
|
resolveWithNodejsStrategy :: ( Member (Modules address value) effects
|
||||||
, Reader M.ModuleInfo
|
, Member (Reader M.ModuleInfo) effects
|
||||||
, Reader PackageInfo
|
, Member (Reader PackageInfo) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
)
|
||||||
=> ImportPath
|
=> ImportPath
|
||||||
-> [String]
|
-> [String]
|
||||||
-> Evaluator location value effects M.ModulePath
|
-> Evaluator address value effects M.ModulePath
|
||||||
resolveWithNodejsStrategy (ImportPath path Relative) exts = resolveRelativePath path exts
|
resolveWithNodejsStrategy (ImportPath path Relative) exts = resolveRelativePath path exts
|
||||||
resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts
|
resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts
|
||||||
|
|
||||||
@ -56,15 +56,15 @@ resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativ
|
|||||||
-- /root/src/moduleB.ts
|
-- /root/src/moduleB.ts
|
||||||
-- /root/src/moduleB/package.json (if it specifies a "types" property)
|
-- /root/src/moduleB/package.json (if it specifies a "types" property)
|
||||||
-- /root/src/moduleB/index.ts
|
-- /root/src/moduleB/index.ts
|
||||||
resolveRelativePath :: Members '[ Modules location value
|
resolveRelativePath :: ( Member (Modules address value) effects
|
||||||
, Reader M.ModuleInfo
|
, Member (Reader M.ModuleInfo) effects
|
||||||
, Reader PackageInfo
|
, Member (Reader PackageInfo) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
)
|
||||||
=> FilePath
|
=> FilePath
|
||||||
-> [String]
|
-> [String]
|
||||||
-> Evaluator location value effects M.ModulePath
|
-> Evaluator address value effects M.ModulePath
|
||||||
resolveRelativePath relImportPath exts = do
|
resolveRelativePath relImportPath exts = do
|
||||||
M.ModuleInfo{..} <- currentModule
|
M.ModuleInfo{..} <- currentModule
|
||||||
let relRootDir = takeDirectory modulePath
|
let relRootDir = takeDirectory modulePath
|
||||||
@ -84,15 +84,15 @@ resolveRelativePath relImportPath exts = do
|
|||||||
--
|
--
|
||||||
-- /root/node_modules/moduleB.ts, etc
|
-- /root/node_modules/moduleB.ts, etc
|
||||||
-- /node_modules/moduleB.ts, etc
|
-- /node_modules/moduleB.ts, etc
|
||||||
resolveNonRelativePath :: Members '[ Modules location value
|
resolveNonRelativePath :: ( Member (Modules address value) effects
|
||||||
, Reader M.ModuleInfo
|
, Member (Reader M.ModuleInfo) effects
|
||||||
, Reader PackageInfo
|
, Member (Reader PackageInfo) effects
|
||||||
, Resumable ResolutionError
|
, Member (Resumable ResolutionError) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
)
|
||||||
=> FilePath
|
=> FilePath
|
||||||
-> [String]
|
-> [String]
|
||||||
-> Evaluator location value effects M.ModulePath
|
-> Evaluator address value effects M.ModulePath
|
||||||
resolveNonRelativePath name exts = do
|
resolveNonRelativePath name exts = do
|
||||||
M.ModuleInfo{..} <- currentModule
|
M.ModuleInfo{..} <- currentModule
|
||||||
go "." modulePath mempty
|
go "." modulePath mempty
|
||||||
@ -109,13 +109,13 @@ resolveNonRelativePath name exts = do
|
|||||||
notFound xs = throwResumable $ NotFoundError name xs Language.TypeScript
|
notFound xs = throwResumable $ NotFoundError name xs Language.TypeScript
|
||||||
|
|
||||||
-- | Resolve a module name to a ModulePath.
|
-- | Resolve a module name to a ModulePath.
|
||||||
resolveModule :: Members '[ Modules location value
|
resolveModule :: ( Member (Modules address value) effects
|
||||||
, Reader PackageInfo
|
, Member (Reader PackageInfo) effects
|
||||||
, Trace
|
, Member Trace effects
|
||||||
] effects
|
)
|
||||||
=> FilePath -- ^ Module path used as directory to search in
|
=> FilePath -- ^ Module path used as directory to search in
|
||||||
-> [String] -- ^ File extensions to look for
|
-> [String] -- ^ File extensions to look for
|
||||||
-> Evaluator location value effects (Either [FilePath] M.ModulePath)
|
-> Evaluator address value effects (Either [FilePath] M.ModulePath)
|
||||||
resolveModule path' exts = do
|
resolveModule path' exts = do
|
||||||
let path = makeRelative "." path'
|
let path = makeRelative "." path'
|
||||||
PackageInfo{..} <- currentPackage
|
PackageInfo{..} <- currentPackage
|
||||||
@ -132,29 +132,26 @@ typescriptExtensions = ["ts", "tsx", "d.ts"]
|
|||||||
javascriptExtensions :: [String]
|
javascriptExtensions :: [String]
|
||||||
javascriptExtensions = ["js"]
|
javascriptExtensions = ["js"]
|
||||||
|
|
||||||
evalRequire :: ( AbstractValue location value effects
|
evalRequire :: ( AbstractValue address value effects
|
||||||
, Members '[ Allocator location value
|
, Member (Allocator address value) effects
|
||||||
, Modules location value
|
, Member (Modules address value) effects
|
||||||
, Reader (Environment location)
|
, Member (Reader (Environment address)) effects
|
||||||
, State (Environment location)
|
, Member (State (Environment address)) effects
|
||||||
, State (Exports location)
|
, Member (State (Exports address)) effects
|
||||||
, State (Heap location (Cell location) value)
|
, Member (State (Heap address (Cell address) value)) effects
|
||||||
, Trace
|
, Ord address
|
||||||
] effects
|
, Reducer value (Cell address value)
|
||||||
, Ord location
|
|
||||||
, Reducer value (Cell location value)
|
|
||||||
)
|
)
|
||||||
=> M.ModulePath
|
=> M.ModulePath
|
||||||
-> Name
|
-> Name
|
||||||
-> Evaluator location value effects value
|
-> Evaluator address value effects value
|
||||||
evalRequire modulePath alias = letrec' alias $ \addr -> do
|
evalRequire modulePath alias = letrec' alias $ \addr -> do
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
|
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
|
||||||
modifyEnv (mergeEnvs importedEnv)
|
bindAll importedEnv
|
||||||
void $ makeNamespace alias addr Nothing
|
unit <$ makeNamespace alias addr Nothing
|
||||||
unit
|
|
||||||
|
|
||||||
data Import a = Import { importSymbols :: ![(Name, Name)], importFrom :: ImportPath }
|
data Import a = Import { importSymbols :: ![(Name, Name)], importFrom :: ImportPath }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Import
|
instance ToJSONFields1 Import
|
||||||
|
|
||||||
@ -167,14 +164,14 @@ instance Evaluatable Import where
|
|||||||
eval (Import symbols importPath) = do
|
eval (Import symbols importPath) = do
|
||||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
||||||
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
|
importedEnv <- maybe emptyEnv fst <$> isolate (require modulePath)
|
||||||
modifyEnv (mergeEnvs (renamed importedEnv)) *> (Rval <$> unit)
|
bindAll (renamed importedEnv) $> Rval unit
|
||||||
where
|
where
|
||||||
renamed importedEnv
|
renamed importedEnv
|
||||||
| Prologue.null symbols = importedEnv
|
| Prologue.null symbols = importedEnv
|
||||||
| otherwise = Env.overwrite symbols importedEnv
|
| otherwise = Env.overwrite symbols importedEnv
|
||||||
|
|
||||||
data JavaScriptRequire a = JavaScriptRequire { javascriptRequireIden :: !a, javascriptRequireFrom :: ImportPath }
|
data JavaScriptRequire a = JavaScriptRequire { javascriptRequireIden :: !a, javascriptRequireFrom :: ImportPath }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 JavaScriptRequire where liftEq = genericLiftEq
|
instance Eq1 JavaScriptRequire where liftEq = genericLiftEq
|
||||||
instance Ord1 JavaScriptRequire where liftCompare = genericLiftCompare
|
instance Ord1 JavaScriptRequire where liftCompare = genericLiftCompare
|
||||||
@ -190,7 +187,7 @@ instance Evaluatable JavaScriptRequire where
|
|||||||
|
|
||||||
|
|
||||||
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath }
|
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq
|
instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq
|
||||||
instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare
|
instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare
|
||||||
@ -205,7 +202,7 @@ instance Evaluatable QualifiedAliasedImport where
|
|||||||
Rval <$> evalRequire modulePath alias
|
Rval <$> evalRequire modulePath alias
|
||||||
|
|
||||||
newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
|
newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 SideEffectImport where liftEq = genericLiftEq
|
instance Eq1 SideEffectImport where liftEq = genericLiftEq
|
||||||
instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
|
instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
|
||||||
@ -217,12 +214,12 @@ instance Evaluatable SideEffectImport where
|
|||||||
eval (SideEffectImport importPath) = do
|
eval (SideEffectImport importPath) = do
|
||||||
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
|
||||||
void $ isolate (require modulePath)
|
void $ isolate (require modulePath)
|
||||||
Rval <$> unit
|
pure (Rval unit)
|
||||||
|
|
||||||
|
|
||||||
-- | Qualified Export declarations
|
-- | Qualified Export declarations
|
||||||
newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [(Name, Name)] }
|
newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [(Name, Name)] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 QualifiedExport where liftEq = genericLiftEq
|
instance Eq1 QualifiedExport where liftEq = genericLiftEq
|
||||||
instance Ord1 QualifiedExport where liftCompare = genericLiftCompare
|
instance Ord1 QualifiedExport where liftCompare = genericLiftCompare
|
||||||
@ -235,12 +232,12 @@ instance Evaluatable QualifiedExport where
|
|||||||
-- Insert the aliases with no addresses.
|
-- Insert the aliases with no addresses.
|
||||||
for_ exportSymbols $ \(name, alias) ->
|
for_ exportSymbols $ \(name, alias) ->
|
||||||
addExport name alias Nothing
|
addExport name alias Nothing
|
||||||
Rval <$> unit
|
pure (Rval unit)
|
||||||
|
|
||||||
|
|
||||||
-- | Qualified Export declarations that export from another module.
|
-- | Qualified Export declarations that export from another module.
|
||||||
data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: ImportPath, qualifiedExportFromSymbols :: ![(Name, Name)]}
|
data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: ImportPath, qualifiedExportFromSymbols :: ![(Name, Name)]}
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq
|
instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq
|
||||||
instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare
|
instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare
|
||||||
@ -256,10 +253,10 @@ instance Evaluatable QualifiedExportFrom where
|
|||||||
for_ exportSymbols $ \(name, alias) -> do
|
for_ exportSymbols $ \(name, alias) -> do
|
||||||
let address = Env.lookup name importedEnv
|
let address = Env.lookup name importedEnv
|
||||||
maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address
|
maybe (throwEvalError $ ExportError modulePath name) (addExport name alias . Just) address
|
||||||
Rval <$> unit
|
pure (Rval unit)
|
||||||
|
|
||||||
newtype DefaultExport a = DefaultExport { defaultExport :: a }
|
newtype DefaultExport a = DefaultExport { defaultExport :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 DefaultExport
|
instance ToJSONFields1 DefaultExport
|
||||||
|
|
||||||
@ -275,14 +272,14 @@ instance Evaluatable DefaultExport where
|
|||||||
addr <- lookupOrAlloc name
|
addr <- lookupOrAlloc name
|
||||||
assign addr v
|
assign addr v
|
||||||
addExport name name Nothing
|
addExport name name Nothing
|
||||||
void $ modifyEnv (Env.insert name addr)
|
void $ bind name addr
|
||||||
Nothing -> throwEvalError DefaultExportError
|
Nothing -> throwEvalError DefaultExportError
|
||||||
Rval <$> unit
|
pure (Rval unit)
|
||||||
|
|
||||||
|
|
||||||
-- | Lookup type for a type-level key in a typescript map.
|
-- | Lookup type for a type-level key in a typescript map.
|
||||||
data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a }
|
data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 LookupType
|
instance ToJSONFields1 LookupType
|
||||||
|
|
||||||
@ -293,7 +290,7 @@ instance Evaluatable LookupType
|
|||||||
|
|
||||||
-- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo }
|
-- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo }
|
||||||
newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier ByteString
|
newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ShorthandPropertyIdentifier
|
instance ToJSONFields1 ShorthandPropertyIdentifier
|
||||||
|
|
||||||
@ -303,7 +300,7 @@ instance Show1 ShorthandPropertyIdentifier where liftShowsPrec = genericLiftShow
|
|||||||
instance Evaluatable ShorthandPropertyIdentifier
|
instance Evaluatable ShorthandPropertyIdentifier
|
||||||
|
|
||||||
data Union a = Union { _unionLeft :: !a, _unionRight :: !a }
|
data Union a = Union { _unionLeft :: !a, _unionRight :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Language.TypeScript.Syntax.Union
|
instance ToJSONFields1 Language.TypeScript.Syntax.Union
|
||||||
|
|
||||||
@ -313,7 +310,7 @@ instance Show1 Language.TypeScript.Syntax.Union where liftShowsPrec = genericLif
|
|||||||
instance Evaluatable Language.TypeScript.Syntax.Union
|
instance Evaluatable Language.TypeScript.Syntax.Union
|
||||||
|
|
||||||
data Intersection a = Intersection { _intersectionLeft :: !a, _intersectionRight :: !a }
|
data Intersection a = Intersection { _intersectionLeft :: !a, _intersectionRight :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Intersection
|
instance ToJSONFields1 Intersection
|
||||||
|
|
||||||
@ -323,7 +320,7 @@ instance Show1 Intersection where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Intersection
|
instance Evaluatable Intersection
|
||||||
|
|
||||||
data FunctionType a = FunctionType { _functionTypeParameters :: !a, _functionFormalParameters :: ![a], _functionType :: !a }
|
data FunctionType a = FunctionType { _functionTypeParameters :: !a, _functionFormalParameters :: ![a], _functionType :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 FunctionType
|
instance ToJSONFields1 FunctionType
|
||||||
|
|
||||||
@ -333,7 +330,7 @@ instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable FunctionType
|
instance Evaluatable FunctionType
|
||||||
|
|
||||||
data AmbientFunction a = AmbientFunction { _ambientFunctionContext :: ![a], _ambientFunctionIdentifier :: !a, _ambientFunctionParameters :: ![a] }
|
data AmbientFunction a = AmbientFunction { _ambientFunctionContext :: ![a], _ambientFunctionIdentifier :: !a, _ambientFunctionParameters :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 AmbientFunction
|
instance ToJSONFields1 AmbientFunction
|
||||||
|
|
||||||
@ -343,7 +340,7 @@ instance Show1 AmbientFunction where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable AmbientFunction
|
instance Evaluatable AmbientFunction
|
||||||
|
|
||||||
data ImportRequireClause a = ImportRequireClause { _importRequireIdentifier :: !a, _importRequireSubject :: !a }
|
data ImportRequireClause a = ImportRequireClause { _importRequireIdentifier :: !a, _importRequireSubject :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ImportRequireClause
|
instance ToJSONFields1 ImportRequireClause
|
||||||
|
|
||||||
@ -353,7 +350,7 @@ instance Show1 ImportRequireClause where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ImportRequireClause
|
instance Evaluatable ImportRequireClause
|
||||||
|
|
||||||
newtype ImportClause a = ImportClause { _importClauseElements :: [a] }
|
newtype ImportClause a = ImportClause { _importClauseElements :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ImportClause
|
instance ToJSONFields1 ImportClause
|
||||||
|
|
||||||
@ -363,7 +360,7 @@ instance Show1 ImportClause where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ImportClause
|
instance Evaluatable ImportClause
|
||||||
|
|
||||||
newtype Tuple a = Tuple { _tupleElements :: [a] }
|
newtype Tuple a = Tuple { _tupleElements :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Tuple
|
instance ToJSONFields1 Tuple
|
||||||
|
|
||||||
@ -375,7 +372,7 @@ instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Tuple
|
instance Evaluatable Tuple
|
||||||
|
|
||||||
data Constructor a = Constructor { _constructorTypeParameters :: !a, _constructorFormalParameters :: ![a], _constructorType :: !a }
|
data Constructor a = Constructor { _constructorTypeParameters :: !a, _constructorFormalParameters :: ![a], _constructorType :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Language.TypeScript.Syntax.Constructor
|
instance ToJSONFields1 Language.TypeScript.Syntax.Constructor
|
||||||
|
|
||||||
@ -385,7 +382,7 @@ instance Show1 Language.TypeScript.Syntax.Constructor where liftShowsPrec = gene
|
|||||||
instance Evaluatable Language.TypeScript.Syntax.Constructor
|
instance Evaluatable Language.TypeScript.Syntax.Constructor
|
||||||
|
|
||||||
data TypeParameter a = TypeParameter { _typeParameter :: !a, _typeParameterConstraint :: !a, _typeParameterDefaultType :: !a }
|
data TypeParameter a = TypeParameter { _typeParameter :: !a, _typeParameterConstraint :: !a, _typeParameterDefaultType :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 TypeParameter
|
instance ToJSONFields1 TypeParameter
|
||||||
|
|
||||||
@ -395,7 +392,7 @@ instance Show1 TypeParameter where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TypeParameter
|
instance Evaluatable TypeParameter
|
||||||
|
|
||||||
data TypeAssertion a = TypeAssertion { _typeAssertionParameters :: !a, _typeAssertionExpression :: !a }
|
data TypeAssertion a = TypeAssertion { _typeAssertionParameters :: !a, _typeAssertionExpression :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 TypeAssertion
|
instance ToJSONFields1 TypeAssertion
|
||||||
|
|
||||||
@ -405,7 +402,7 @@ instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TypeAssertion
|
instance Evaluatable TypeAssertion
|
||||||
|
|
||||||
newtype Annotation a = Annotation { _annotationType :: a }
|
newtype Annotation a = Annotation { _annotationType :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Annotation
|
instance ToJSONFields1 Annotation
|
||||||
|
|
||||||
@ -415,7 +412,7 @@ instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Annotation
|
instance Evaluatable Annotation
|
||||||
|
|
||||||
newtype Decorator a = Decorator { _decoratorTerm :: a }
|
newtype Decorator a = Decorator { _decoratorTerm :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Decorator
|
instance ToJSONFields1 Decorator
|
||||||
|
|
||||||
@ -425,7 +422,7 @@ instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Decorator
|
instance Evaluatable Decorator
|
||||||
|
|
||||||
newtype ComputedPropertyName a = ComputedPropertyName a
|
newtype ComputedPropertyName a = ComputedPropertyName a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ComputedPropertyName
|
instance ToJSONFields1 ComputedPropertyName
|
||||||
|
|
||||||
@ -435,7 +432,7 @@ instance Show1 ComputedPropertyName where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ComputedPropertyName
|
instance Evaluatable ComputedPropertyName
|
||||||
|
|
||||||
newtype Constraint a = Constraint { _constraintType :: a }
|
newtype Constraint a = Constraint { _constraintType :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Constraint
|
instance ToJSONFields1 Constraint
|
||||||
|
|
||||||
@ -445,7 +442,7 @@ instance Show1 Constraint where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Constraint
|
instance Evaluatable Constraint
|
||||||
|
|
||||||
newtype DefaultType a = DefaultType { _defaultType :: a }
|
newtype DefaultType a = DefaultType { _defaultType :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 DefaultType
|
instance ToJSONFields1 DefaultType
|
||||||
|
|
||||||
@ -455,7 +452,7 @@ instance Show1 DefaultType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable DefaultType
|
instance Evaluatable DefaultType
|
||||||
|
|
||||||
newtype ParenthesizedType a = ParenthesizedType { _parenthesizedType :: a }
|
newtype ParenthesizedType a = ParenthesizedType { _parenthesizedType :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ParenthesizedType
|
instance ToJSONFields1 ParenthesizedType
|
||||||
|
|
||||||
@ -465,7 +462,7 @@ instance Show1 ParenthesizedType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ParenthesizedType
|
instance Evaluatable ParenthesizedType
|
||||||
|
|
||||||
newtype PredefinedType a = PredefinedType { _predefinedType :: ByteString }
|
newtype PredefinedType a = PredefinedType { _predefinedType :: ByteString }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 PredefinedType
|
instance ToJSONFields1 PredefinedType
|
||||||
|
|
||||||
@ -475,7 +472,7 @@ instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable PredefinedType
|
instance Evaluatable PredefinedType
|
||||||
|
|
||||||
newtype TypeIdentifier a = TypeIdentifier ByteString
|
newtype TypeIdentifier a = TypeIdentifier ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 TypeIdentifier
|
instance ToJSONFields1 TypeIdentifier
|
||||||
|
|
||||||
@ -485,7 +482,7 @@ instance Show1 TypeIdentifier where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TypeIdentifier
|
instance Evaluatable TypeIdentifier
|
||||||
|
|
||||||
data NestedIdentifier a = NestedIdentifier !a !a
|
data NestedIdentifier a = NestedIdentifier !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 NestedIdentifier
|
instance ToJSONFields1 NestedIdentifier
|
||||||
|
|
||||||
@ -495,7 +492,7 @@ instance Show1 NestedIdentifier where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable NestedIdentifier
|
instance Evaluatable NestedIdentifier
|
||||||
|
|
||||||
data NestedTypeIdentifier a = NestedTypeIdentifier !a !a
|
data NestedTypeIdentifier a = NestedTypeIdentifier !a !a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 NestedTypeIdentifier
|
instance ToJSONFields1 NestedTypeIdentifier
|
||||||
|
|
||||||
@ -505,7 +502,7 @@ instance Show1 NestedTypeIdentifier where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable NestedTypeIdentifier
|
instance Evaluatable NestedTypeIdentifier
|
||||||
|
|
||||||
data GenericType a = GenericType { _genericTypeIdentifier :: !a, _genericTypeArguments :: !a }
|
data GenericType a = GenericType { _genericTypeIdentifier :: !a, _genericTypeArguments :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 GenericType
|
instance ToJSONFields1 GenericType
|
||||||
|
|
||||||
@ -515,7 +512,7 @@ instance Show1 GenericType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable GenericType
|
instance Evaluatable GenericType
|
||||||
|
|
||||||
data TypePredicate a = TypePredicate { _typePredicateIdentifier :: !a, _typePredicateType :: !a }
|
data TypePredicate a = TypePredicate { _typePredicateIdentifier :: !a, _typePredicateType :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 TypePredicate
|
instance ToJSONFields1 TypePredicate
|
||||||
|
|
||||||
@ -525,7 +522,7 @@ instance Show1 TypePredicate where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TypePredicate
|
instance Evaluatable TypePredicate
|
||||||
|
|
||||||
newtype ObjectType a = ObjectType { _objectTypeElements :: [a] }
|
newtype ObjectType a = ObjectType { _objectTypeElements :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ObjectType
|
instance ToJSONFields1 ObjectType
|
||||||
|
|
||||||
@ -535,7 +532,7 @@ instance Show1 ObjectType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ObjectType
|
instance Evaluatable ObjectType
|
||||||
|
|
||||||
data With a = With { _withExpression :: !a, _withBody :: !a }
|
data With a = With { _withExpression :: !a, _withBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 With
|
instance ToJSONFields1 With
|
||||||
|
|
||||||
@ -545,7 +542,7 @@ instance Show1 With where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable With
|
instance Evaluatable With
|
||||||
|
|
||||||
newtype AmbientDeclaration a = AmbientDeclaration { _ambientDeclarationBody :: a }
|
newtype AmbientDeclaration a = AmbientDeclaration { _ambientDeclarationBody :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 AmbientDeclaration
|
instance ToJSONFields1 AmbientDeclaration
|
||||||
|
|
||||||
@ -557,7 +554,7 @@ instance Evaluatable AmbientDeclaration where
|
|||||||
eval (AmbientDeclaration body) = subtermRef body
|
eval (AmbientDeclaration body) = subtermRef body
|
||||||
|
|
||||||
data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, _enumDeclarationBody :: ![a] }
|
data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, _enumDeclarationBody :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 EnumDeclaration
|
instance ToJSONFields1 EnumDeclaration
|
||||||
|
|
||||||
@ -570,7 +567,7 @@ instance Declarations a => Declarations (EnumDeclaration a) where
|
|||||||
declaredName EnumDeclaration{..} = declaredName enumDeclarationIdentifier
|
declaredName EnumDeclaration{..} = declaredName enumDeclarationIdentifier
|
||||||
|
|
||||||
newtype ExtendsClause a = ExtendsClause { _extendsClauses :: [a] }
|
newtype ExtendsClause a = ExtendsClause { _extendsClauses :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ExtendsClause
|
instance ToJSONFields1 ExtendsClause
|
||||||
|
|
||||||
@ -580,7 +577,7 @@ instance Show1 ExtendsClause where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ExtendsClause
|
instance Evaluatable ExtendsClause
|
||||||
|
|
||||||
newtype ArrayType a = ArrayType { _arrayType :: a }
|
newtype ArrayType a = ArrayType { _arrayType :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ArrayType
|
instance ToJSONFields1 ArrayType
|
||||||
|
|
||||||
@ -590,7 +587,7 @@ instance Show1 ArrayType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ArrayType
|
instance Evaluatable ArrayType
|
||||||
|
|
||||||
newtype FlowMaybeType a = FlowMaybeType { _flowMaybeType :: a }
|
newtype FlowMaybeType a = FlowMaybeType { _flowMaybeType :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 FlowMaybeType
|
instance ToJSONFields1 FlowMaybeType
|
||||||
|
|
||||||
@ -600,7 +597,7 @@ instance Show1 FlowMaybeType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable FlowMaybeType
|
instance Evaluatable FlowMaybeType
|
||||||
|
|
||||||
newtype TypeQuery a = TypeQuery { _typeQuerySubject :: a }
|
newtype TypeQuery a = TypeQuery { _typeQuerySubject :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 TypeQuery
|
instance ToJSONFields1 TypeQuery
|
||||||
|
|
||||||
@ -610,7 +607,7 @@ instance Show1 TypeQuery where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TypeQuery
|
instance Evaluatable TypeQuery
|
||||||
|
|
||||||
newtype IndexTypeQuery a = IndexTypeQuery { _indexTypeQuerySubject :: a }
|
newtype IndexTypeQuery a = IndexTypeQuery { _indexTypeQuerySubject :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 IndexTypeQuery
|
instance ToJSONFields1 IndexTypeQuery
|
||||||
|
|
||||||
@ -620,7 +617,7 @@ instance Show1 IndexTypeQuery where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable IndexTypeQuery
|
instance Evaluatable IndexTypeQuery
|
||||||
|
|
||||||
newtype TypeArguments a = TypeArguments { _typeArguments :: [a] }
|
newtype TypeArguments a = TypeArguments { _typeArguments :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 TypeArguments
|
instance ToJSONFields1 TypeArguments
|
||||||
|
|
||||||
@ -630,7 +627,7 @@ instance Show1 TypeArguments where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable TypeArguments
|
instance Evaluatable TypeArguments
|
||||||
|
|
||||||
newtype ThisType a = ThisType ByteString
|
newtype ThisType a = ThisType ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ThisType
|
instance ToJSONFields1 ThisType
|
||||||
|
|
||||||
@ -640,7 +637,7 @@ instance Show1 ThisType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ThisType
|
instance Evaluatable ThisType
|
||||||
|
|
||||||
newtype ExistentialType a = ExistentialType ByteString
|
newtype ExistentialType a = ExistentialType ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ExistentialType
|
instance ToJSONFields1 ExistentialType
|
||||||
|
|
||||||
@ -650,7 +647,7 @@ instance Show1 ExistentialType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ExistentialType
|
instance Evaluatable ExistentialType
|
||||||
|
|
||||||
newtype LiteralType a = LiteralType { _literalTypeSubject :: a }
|
newtype LiteralType a = LiteralType { _literalTypeSubject :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 LiteralType
|
instance ToJSONFields1 LiteralType
|
||||||
|
|
||||||
@ -660,7 +657,7 @@ instance Show1 LiteralType where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable LiteralType
|
instance Evaluatable LiteralType
|
||||||
|
|
||||||
data PropertySignature a = PropertySignature { _modifiers :: ![a], _propertySignaturePropertyName :: !a }
|
data PropertySignature a = PropertySignature { _modifiers :: ![a], _propertySignaturePropertyName :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 PropertySignature
|
instance ToJSONFields1 PropertySignature
|
||||||
|
|
||||||
@ -670,7 +667,7 @@ instance Show1 PropertySignature where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable PropertySignature
|
instance Evaluatable PropertySignature
|
||||||
|
|
||||||
data CallSignature a = CallSignature { _callSignatureTypeParameters :: !a, _callSignatureParameters :: ![a], _callSignatureType :: !a }
|
data CallSignature a = CallSignature { _callSignatureTypeParameters :: !a, _callSignatureParameters :: ![a], _callSignatureType :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 CallSignature
|
instance ToJSONFields1 CallSignature
|
||||||
|
|
||||||
@ -681,7 +678,7 @@ instance Evaluatable CallSignature
|
|||||||
|
|
||||||
-- | Todo: Move type params and type to context
|
-- | Todo: Move type params and type to context
|
||||||
data ConstructSignature a = ConstructSignature { _constructSignatureTypeParameters :: !a, _constructSignatureParameters :: ![a], _constructSignatureType :: !a }
|
data ConstructSignature a = ConstructSignature { _constructSignatureTypeParameters :: !a, _constructSignatureParameters :: ![a], _constructSignatureType :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ConstructSignature
|
instance ToJSONFields1 ConstructSignature
|
||||||
|
|
||||||
@ -691,7 +688,7 @@ instance Show1 ConstructSignature where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ConstructSignature
|
instance Evaluatable ConstructSignature
|
||||||
|
|
||||||
data IndexSignature a = IndexSignature { _indexSignatureSubject :: a, _indexSignatureType :: a }
|
data IndexSignature a = IndexSignature { _indexSignatureSubject :: a, _indexSignatureType :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 IndexSignature
|
instance ToJSONFields1 IndexSignature
|
||||||
|
|
||||||
@ -701,7 +698,7 @@ instance Show1 IndexSignature where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable IndexSignature
|
instance Evaluatable IndexSignature
|
||||||
|
|
||||||
data AbstractMethodSignature a = AbstractMethodSignature { _abstractMethodSignatureContext :: ![a], _abstractMethodSignatureName :: !a, _abstractMethodSignatureParameters :: ![a] }
|
data AbstractMethodSignature a = AbstractMethodSignature { _abstractMethodSignatureContext :: ![a], _abstractMethodSignatureName :: !a, _abstractMethodSignatureParameters :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 AbstractMethodSignature
|
instance ToJSONFields1 AbstractMethodSignature
|
||||||
|
|
||||||
@ -711,7 +708,7 @@ instance Show1 AbstractMethodSignature where liftShowsPrec = genericLiftShowsPre
|
|||||||
instance Evaluatable AbstractMethodSignature
|
instance Evaluatable AbstractMethodSignature
|
||||||
|
|
||||||
data Debugger a = Debugger
|
data Debugger a = Debugger
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Debugger
|
instance ToJSONFields1 Debugger
|
||||||
|
|
||||||
@ -721,7 +718,7 @@ instance Show1 Debugger where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Debugger
|
instance Evaluatable Debugger
|
||||||
|
|
||||||
data ForOf a = ForOf { _forOfBinding :: !a, _forOfSubject :: !a, _forOfBody :: !a }
|
data ForOf a = ForOf { _forOfBinding :: !a, _forOfSubject :: !a, _forOfBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ForOf
|
instance ToJSONFields1 ForOf
|
||||||
|
|
||||||
@ -731,7 +728,7 @@ instance Show1 ForOf where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ForOf
|
instance Evaluatable ForOf
|
||||||
|
|
||||||
data This a = This
|
data This a = This
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 This
|
instance ToJSONFields1 This
|
||||||
|
|
||||||
@ -741,7 +738,7 @@ instance Show1 This where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable This
|
instance Evaluatable This
|
||||||
|
|
||||||
data LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: !a, _labeledStatementSubject :: !a }
|
data LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: !a, _labeledStatementSubject :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 LabeledStatement
|
instance ToJSONFields1 LabeledStatement
|
||||||
|
|
||||||
@ -751,7 +748,7 @@ instance Show1 LabeledStatement where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable LabeledStatement
|
instance Evaluatable LabeledStatement
|
||||||
|
|
||||||
newtype Update a = Update { _updateSubject :: a }
|
newtype Update a = Update { _updateSubject :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Update
|
instance ToJSONFields1 Update
|
||||||
|
|
||||||
@ -761,7 +758,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Update
|
instance Evaluatable Update
|
||||||
|
|
||||||
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
|
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 Module where liftEq = genericLiftEq
|
instance Eq1 Module where liftEq = genericLiftEq
|
||||||
instance Ord1 Module where liftCompare = genericLiftCompare
|
instance Ord1 Module where liftCompare = genericLiftCompare
|
||||||
@ -778,7 +775,7 @@ instance Evaluatable Module where
|
|||||||
|
|
||||||
|
|
||||||
data InternalModule a = InternalModule { internalModuleIdentifier :: !a, internalModuleStatements :: ![a] }
|
data InternalModule a = InternalModule { internalModuleIdentifier :: !a, internalModuleStatements :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 InternalModule where liftEq = genericLiftEq
|
instance Eq1 InternalModule where liftEq = genericLiftEq
|
||||||
instance Ord1 InternalModule where liftCompare = genericLiftCompare
|
instance Ord1 InternalModule where liftCompare = genericLiftCompare
|
||||||
@ -797,7 +794,7 @@ instance Declarations a => Declarations (InternalModule a) where
|
|||||||
|
|
||||||
|
|
||||||
data ImportAlias a = ImportAlias { _importAliasSubject :: !a, _importAlias :: !a }
|
data ImportAlias a = ImportAlias { _importAliasSubject :: !a, _importAlias :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ImportAlias
|
instance ToJSONFields1 ImportAlias
|
||||||
|
|
||||||
@ -807,7 +804,7 @@ instance Show1 ImportAlias where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ImportAlias
|
instance Evaluatable ImportAlias
|
||||||
|
|
||||||
data Super a = Super
|
data Super a = Super
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Super
|
instance ToJSONFields1 Super
|
||||||
|
|
||||||
@ -817,7 +814,7 @@ instance Show1 Super where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Super
|
instance Evaluatable Super
|
||||||
|
|
||||||
data Undefined a = Undefined
|
data Undefined a = Undefined
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 Undefined
|
instance ToJSONFields1 Undefined
|
||||||
|
|
||||||
@ -827,7 +824,7 @@ instance Show1 Undefined where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable Undefined
|
instance Evaluatable Undefined
|
||||||
|
|
||||||
data ClassHeritage a = ClassHeritage { _classHeritageExtendsClause :: !a, _implementsClause :: !a }
|
data ClassHeritage a = ClassHeritage { _classHeritageExtendsClause :: !a, _implementsClause :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ClassHeritage
|
instance ToJSONFields1 ClassHeritage
|
||||||
|
|
||||||
@ -837,7 +834,7 @@ instance Show1 ClassHeritage where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ClassHeritage
|
instance Evaluatable ClassHeritage
|
||||||
|
|
||||||
data AbstractClass a = AbstractClass { abstractClassIdentifier :: !a, _abstractClassTypeParameters :: !a, classHeritage :: ![a], classBody :: !a }
|
data AbstractClass a = AbstractClass { abstractClassIdentifier :: !a, _abstractClassTypeParameters :: !a, classHeritage :: ![a], classBody :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance Eq1 AbstractClass where liftEq = genericLiftEq
|
instance Eq1 AbstractClass where liftEq = genericLiftEq
|
||||||
instance Ord1 AbstractClass where liftCompare = genericLiftCompare
|
instance Ord1 AbstractClass where liftCompare = genericLiftCompare
|
||||||
@ -855,11 +852,11 @@ instance Evaluatable AbstractClass where
|
|||||||
void $ subtermValue classBody
|
void $ subtermValue classBody
|
||||||
classEnv <- Env.head <$> getEnv
|
classEnv <- Env.head <$> getEnv
|
||||||
klass name supers classEnv
|
klass name supers classEnv
|
||||||
Rval <$> (v <$ modifyEnv (Env.insert name addr))
|
Rval v <$ bind name addr
|
||||||
|
|
||||||
|
|
||||||
data JsxElement a = JsxElement { _jsxOpeningElement :: !a, _jsxElements :: ![a], _jsxClosingElement :: !a }
|
data JsxElement a = JsxElement { _jsxOpeningElement :: !a, _jsxElements :: ![a], _jsxClosingElement :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 JsxElement
|
instance ToJSONFields1 JsxElement
|
||||||
|
|
||||||
@ -869,7 +866,7 @@ instance Show1 JsxElement where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable JsxElement
|
instance Evaluatable JsxElement
|
||||||
|
|
||||||
newtype JsxText a = JsxText ByteString
|
newtype JsxText a = JsxText ByteString
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 JsxText
|
instance ToJSONFields1 JsxText
|
||||||
|
|
||||||
@ -879,7 +876,7 @@ instance Show1 JsxText where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable JsxText
|
instance Evaluatable JsxText
|
||||||
|
|
||||||
newtype JsxExpression a = JsxExpression { _jsxExpression :: a }
|
newtype JsxExpression a = JsxExpression { _jsxExpression :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 JsxExpression
|
instance ToJSONFields1 JsxExpression
|
||||||
|
|
||||||
@ -889,7 +886,7 @@ instance Show1 JsxExpression where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable JsxExpression
|
instance Evaluatable JsxExpression
|
||||||
|
|
||||||
data JsxOpeningElement a = JsxOpeningElement { _jsxOpeningElementIdentifier :: !a, _jsxAttributes :: ![a] }
|
data JsxOpeningElement a = JsxOpeningElement { _jsxOpeningElementIdentifier :: !a, _jsxAttributes :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 JsxOpeningElement
|
instance ToJSONFields1 JsxOpeningElement
|
||||||
|
|
||||||
@ -899,7 +896,7 @@ instance Show1 JsxOpeningElement where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable JsxOpeningElement
|
instance Evaluatable JsxOpeningElement
|
||||||
|
|
||||||
newtype JsxClosingElement a = JsxClosingElement { _jsxClosingElementIdentifier :: a }
|
newtype JsxClosingElement a = JsxClosingElement { _jsxClosingElementIdentifier :: a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 JsxClosingElement
|
instance ToJSONFields1 JsxClosingElement
|
||||||
|
|
||||||
@ -909,7 +906,7 @@ instance Show1 JsxClosingElement where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable JsxClosingElement
|
instance Evaluatable JsxClosingElement
|
||||||
|
|
||||||
data JsxSelfClosingElement a = JsxSelfClosingElement { _jsxSelfClosingElementIdentifier :: !a, _jsxSelfClosingElementAttributes :: ![a] }
|
data JsxSelfClosingElement a = JsxSelfClosingElement { _jsxSelfClosingElementIdentifier :: !a, _jsxSelfClosingElementAttributes :: ![a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 JsxSelfClosingElement
|
instance ToJSONFields1 JsxSelfClosingElement
|
||||||
|
|
||||||
@ -919,7 +916,7 @@ instance Show1 JsxSelfClosingElement where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable JsxSelfClosingElement
|
instance Evaluatable JsxSelfClosingElement
|
||||||
|
|
||||||
data JsxAttribute a = JsxAttribute { _jsxAttributeTarget :: !a, _jsxAttributeValue :: !a }
|
data JsxAttribute a = JsxAttribute { _jsxAttributeTarget :: !a, _jsxAttributeValue :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 JsxAttribute
|
instance ToJSONFields1 JsxAttribute
|
||||||
|
|
||||||
@ -929,7 +926,7 @@ instance Show1 JsxAttribute where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable JsxAttribute
|
instance Evaluatable JsxAttribute
|
||||||
|
|
||||||
newtype ImplementsClause a = ImplementsClause { _implementsClauseTypes :: [a] }
|
newtype ImplementsClause a = ImplementsClause { _implementsClauseTypes :: [a] }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 ImplementsClause
|
instance ToJSONFields1 ImplementsClause
|
||||||
|
|
||||||
@ -939,7 +936,7 @@ instance Show1 ImplementsClause where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable ImplementsClause
|
instance Evaluatable ImplementsClause
|
||||||
|
|
||||||
data OptionalParameter a = OptionalParameter { _optionalParameterContext :: ![a], _optionalParameterSubject :: !a }
|
data OptionalParameter a = OptionalParameter { _optionalParameterContext :: ![a], _optionalParameterSubject :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 OptionalParameter
|
instance ToJSONFields1 OptionalParameter
|
||||||
|
|
||||||
@ -949,7 +946,7 @@ instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable OptionalParameter
|
instance Evaluatable OptionalParameter
|
||||||
|
|
||||||
data RequiredParameter a = RequiredParameter { _requiredParameterContext :: ![a], _requiredParameterSubject :: !a }
|
data RequiredParameter a = RequiredParameter { _requiredParameterContext :: ![a], _requiredParameterSubject :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 RequiredParameter
|
instance ToJSONFields1 RequiredParameter
|
||||||
|
|
||||||
@ -959,7 +956,7 @@ instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable RequiredParameter
|
instance Evaluatable RequiredParameter
|
||||||
|
|
||||||
data RestParameter a = RestParameter { _restParameterContext :: ![a], _restParameterSubject :: !a }
|
data RestParameter a = RestParameter { _restParameterContext :: ![a], _restParameterSubject :: !a }
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 RestParameter
|
instance ToJSONFields1 RestParameter
|
||||||
|
|
||||||
@ -969,7 +966,7 @@ instance Show1 RestParameter where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable RestParameter
|
instance Evaluatable RestParameter
|
||||||
|
|
||||||
newtype JsxFragment a = JsxFragment [a]
|
newtype JsxFragment a = JsxFragment [a]
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 JsxFragment
|
instance ToJSONFields1 JsxFragment
|
||||||
|
|
||||||
@ -979,7 +976,7 @@ instance Show1 JsxFragment where liftShowsPrec = genericLiftShowsPrec
|
|||||||
instance Evaluatable JsxFragment
|
instance Evaluatable JsxFragment
|
||||||
|
|
||||||
data JsxNamespaceName a = JsxNamespaceName a a
|
data JsxNamespaceName a = JsxNamespaceName a a
|
||||||
deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
|
||||||
|
|
||||||
instance ToJSONFields1 JsxNamespaceName
|
instance ToJSONFields1 JsxNamespaceName
|
||||||
|
|
||||||
|
@ -69,7 +69,7 @@ bracket' before after action = do
|
|||||||
|
|
||||||
-- | Parse 'Source' with the given 'TS.Language' and return its AST.
|
-- | Parse 'Source' with the given 'TS.Language' and return its AST.
|
||||||
-- Returns Nothing if the operation timed out.
|
-- Returns Nothing if the operation timed out.
|
||||||
parseToAST :: (Bounded grammar, Enum grammar, Members '[Trace, IO] effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar))
|
parseToAST :: (Bounded grammar, Enum grammar, Member IO effects, Member Trace 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
|
parseToAST (Milliseconds s) language Blob{..} = bracket' TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do
|
||||||
let parserTimeout = s * 1000
|
let parserTimeout = s * 1000
|
||||||
|
|
||||||
|
@ -35,7 +35,6 @@ import Control.Monad as X hiding (fail, return, unless, when)
|
|||||||
import Control.Monad.Except as X (MonadError (..))
|
import Control.Monad.Except as X (MonadError (..))
|
||||||
import Control.Monad.Fail as X (MonadFail (..))
|
import Control.Monad.Fail as X (MonadFail (..))
|
||||||
import Data.Algebra as X
|
import Data.Algebra as X
|
||||||
import Data.Align.Generic as X (GAlign)
|
|
||||||
import Data.Bifoldable as X
|
import Data.Bifoldable as X
|
||||||
import Data.Bifunctor as X (Bifunctor (..))
|
import Data.Bifunctor as X (Bifunctor (..))
|
||||||
import Data.Bitraversable as X
|
import Data.Bitraversable as X
|
||||||
|
@ -28,7 +28,7 @@ runGraph :: Eff '[Fresh, Reader (Graph vertex)] (Graph vertex) -> Graph vertex
|
|||||||
runGraph = run . runReader mempty . runFresh 0
|
runGraph = run . runReader mempty . runFresh 0
|
||||||
|
|
||||||
|
|
||||||
termAlgebra :: (ConstructorName syntax, Foldable syntax, Members '[Fresh, Reader (Graph (Vertex tag))] effs)
|
termAlgebra :: (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (Vertex tag))) effs)
|
||||||
=> tag
|
=> tag
|
||||||
-> TermF syntax ann (Eff effs (Graph (Vertex tag)))
|
-> TermF syntax ann (Eff effs (Graph (Vertex tag)))
|
||||||
-> Eff effs (Graph (Vertex tag))
|
-> Eff effs (Graph (Vertex tag))
|
||||||
@ -63,7 +63,7 @@ data DiffTag = Deleted | Inserted | Merged
|
|||||||
|
|
||||||
|
|
||||||
class ToTreeGraph vertex t | t -> vertex where
|
class ToTreeGraph vertex t | t -> vertex where
|
||||||
toTreeGraph :: Members '[Fresh, Reader (Graph vertex)] effs => t (Eff effs (Graph vertex)) -> Eff effs (Graph vertex)
|
toTreeGraph :: (Member Fresh effs, Member (Reader (Graph vertex)) effs) => t (Eff effs (Graph vertex)) -> Eff effs (Graph vertex)
|
||||||
|
|
||||||
instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex ()) (TermF syntax ann) where
|
instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex ()) (TermF syntax ann) where
|
||||||
toTreeGraph = termAlgebra ()
|
toTreeGraph = termAlgebra ()
|
||||||
|
@ -16,7 +16,7 @@ data SomeAST where
|
|||||||
withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a
|
withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a
|
||||||
withSomeAST f (SomeAST ast) = f ast
|
withSomeAST f (SomeAST ast) = f ast
|
||||||
|
|
||||||
astParseBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs SomeAST
|
astParseBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs SomeAST
|
||||||
astParseBlob blob@Blob{..}
|
astParseBlob blob@Blob{..}
|
||||||
| Just (SomeASTParser parser) <- someASTParser <$> blobLanguage
|
| Just (SomeASTParser parser) <- someASTParser <$> blobLanguage
|
||||||
= SomeAST <$> parse parser blob
|
= SomeAST <$> parse parser blob
|
||||||
@ -26,7 +26,7 @@ astParseBlob blob@Blob{..}
|
|||||||
data ASTFormat = SExpression | JSON | Show
|
data ASTFormat = SExpression | JSON | Show
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
runASTParse :: Members '[Distribute WrappedTask, Task, Exc SomeException] effects => ASTFormat -> [Blob] -> Eff effects F.Builder
|
runASTParse :: (Member (Distribute WrappedTask) effects, Member Task effects) => ASTFormat -> [Blob] -> Eff effects F.Builder
|
||||||
runASTParse SExpression = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow))))
|
runASTParse SExpression = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow))))
|
||||||
runASTParse Show = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize F.Show)))
|
runASTParse Show = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize F.Show)))
|
||||||
runASTParse JSON = distributeFoldMap (\ blob -> WrapTask (astParseBlob blob >>= withSomeAST (render (renderJSONAST blob)))) >=> serialize F.JSON
|
runASTParse JSON = distributeFoldMap (\ blob -> WrapTask (astParseBlob blob >>= withSomeAST (render (renderJSONAST blob)))) >=> serialize F.JSON
|
||||||
|
@ -20,7 +20,7 @@ import Semantic.Stat as Stat
|
|||||||
import Semantic.Task as Task
|
import Semantic.Task as Task
|
||||||
import Serializing.Format
|
import Serializing.Format
|
||||||
|
|
||||||
runDiff :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => DiffRenderer output -> [BlobPair] -> Eff effs Builder
|
runDiff :: (Member (Distribute WrappedTask) effs, Member Task effs) => DiffRenderer output -> [BlobPair] -> Eff effs Builder
|
||||||
runDiff ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
|
runDiff ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
|
||||||
runDiff JSONDiffRenderer = withParsedBlobPairs (const (decorate constructorLabel >=> decorate identifierLabel)) (render . renderJSONDiff) >=> serialize JSON
|
runDiff JSONDiffRenderer = withParsedBlobPairs (const (decorate constructorLabel >=> decorate identifierLabel)) (render . renderJSONDiff) >=> serialize JSON
|
||||||
runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName)))
|
runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName)))
|
||||||
@ -33,28 +33,28 @@ data SomeTermPair typeclasses ann where
|
|||||||
withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a
|
withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a
|
||||||
withSomeTermPair with (SomeTermPair terms) = with terms
|
withSomeTermPair with (SomeTermPair terms) = with terms
|
||||||
|
|
||||||
diffBlobTOCPairs :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => [BlobPair] -> Eff effs ([TOCSummary], [TOCSummary])
|
diffBlobTOCPairs :: Member (Distribute WrappedTask) effs => [BlobPair] -> Eff effs ([TOCSummary], [TOCSummary])
|
||||||
diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderRPCToCDiff)
|
diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderRPCToCDiff)
|
||||||
|
|
||||||
type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
|
type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
|
||||||
|
|
||||||
withParsedBlobPairs :: (Members '[Distribute WrappedTask, Exc SomeException, IO, Task, Telemetry] effs, Monoid output)
|
withParsedBlobPairs :: (Member (Distribute WrappedTask) effs, Monoid output)
|
||||||
=> (forall syntax . CanDiff syntax => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
|
=> (forall syntax . CanDiff syntax => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
|
||||||
-> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output)
|
-> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output)
|
||||||
-> [BlobPair]
|
-> [BlobPair]
|
||||||
-> Eff effs output
|
-> Eff effs output
|
||||||
withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)))
|
withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)))
|
||||||
where diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax, Members '[IO, Task, Telemetry] effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields))
|
where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member IO effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields))
|
||||||
diffTerms blobs terms = time "diff" languageTag $ do
|
diffTerms blobs terms = time "diff" languageTag $ do
|
||||||
diff <- diff (runJoin terms)
|
diff <- diff (runJoin terms)
|
||||||
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
|
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
|
||||||
where languageTag = languageTagForBlobPair blobs
|
where languageTag = languageTagForBlobPair blobs
|
||||||
|
|
||||||
withParsedBlobPair :: Members '[Distribute WrappedTask, Exc SomeException, Task] effs
|
withParsedBlobPair :: (Member (Distribute WrappedTask) effs, Member (Exc SomeException) effs)
|
||||||
=> (forall syntax . (CanDiff syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
|
=> (forall syntax . (CanDiff syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
|
||||||
-> BlobPair
|
-> BlobPair
|
||||||
-> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, Hashable1, IdentifierName, Show1, ToJSONFields1, Traversable] (Record fields))
|
-> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, IdentifierName, Show1, ToJSONFields1, Traversable] (Record fields))
|
||||||
withParsedBlobPair decorate blobs
|
withParsedBlobPair decorate blobs
|
||||||
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, Hashable1, IdentifierName, Show1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs
|
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, IdentifierName, Show1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs
|
||||||
= SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob))
|
= SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob))
|
||||||
| otherwise = noLanguageForBlob (pathForBlobPair blobs)
|
| otherwise = noLanguageForBlob (pathForBlobPair blobs)
|
||||||
|
@ -39,6 +39,6 @@ data Distribute task output where
|
|||||||
|
|
||||||
|
|
||||||
-- | Evaluate a 'Distribute' effect concurrently.
|
-- | Evaluate a 'Distribute' effect concurrently.
|
||||||
runDistribute :: Members '[Exc SomeException, IO] effs => (forall output . task output -> IO (Either SomeException output)) -> Eff (Distribute task ': effs) a -> Eff effs a
|
runDistribute :: (Member (Exc SomeException) effs, Member IO effs) => (forall output . task output -> IO (Either SomeException output)) -> Eff (Distribute task ': effs) a -> Eff effs a
|
||||||
runDistribute action = interpret (\ (Distribute tasks) ->
|
runDistribute action = interpret (\ (Distribute tasks) ->
|
||||||
liftIO (Async.mapConcurrently action tasks) >>= either throwError pure . sequenceA . withStrategy (parTraversable (parTraversable rseq)))
|
liftIO (Async.mapConcurrently action tasks) >>= either throwError pure . sequenceA . withStrategy (parTraversable (parTraversable rseq)))
|
||||||
|
@ -39,7 +39,7 @@ import Semantic.Task as Task
|
|||||||
|
|
||||||
data GraphType = ImportGraph | CallGraph
|
data GraphType = ImportGraph | CallGraph
|
||||||
|
|
||||||
runGraph :: Members '[Distribute WrappedTask, Files, Resolution, Task, Exc SomeException, Telemetry, Trace] effs
|
runGraph :: ( Member (Distribute WrappedTask) effs, Member (Exc SomeException) effs, Member Files effs, Member Resolution effs, Member Task effs, Member Trace effs)
|
||||||
=> GraphType
|
=> GraphType
|
||||||
-> Bool
|
-> Bool
|
||||||
-> Project
|
-> Project
|
||||||
@ -62,16 +62,16 @@ runGraph graphType includePackages project
|
|||||||
. runIgnoringTrace
|
. runIgnoringTrace
|
||||||
. resumingLoadError
|
. resumingLoadError
|
||||||
. resumingUnspecialized
|
. resumingUnspecialized
|
||||||
. resumingValueError
|
|
||||||
. resumingEnvironmentError
|
. resumingEnvironmentError
|
||||||
. resumingEvalError
|
. resumingEvalError
|
||||||
. resumingResolutionError
|
. resumingResolutionError
|
||||||
. resumingAddressError
|
. resumingAddressError
|
||||||
|
. resumingValueError
|
||||||
|
. runTermEvaluator @_ @_ @(Value (Hole (Located Precise)) (Eff _))
|
||||||
. graphing
|
. graphing
|
||||||
. runTermEvaluator @_ @_ @(Value (Located Precise))
|
|
||||||
|
|
||||||
-- | Parse a list of files into a 'Package'.
|
-- | Parse a list of files into a 'Package'.
|
||||||
parsePackage :: Members '[Distribute WrappedTask, Files, Resolution, Task, Trace] effs
|
parsePackage :: (Member (Distribute WrappedTask) effs, Member Files effs, Member Resolution effs, Member Task effs, Member Trace effs)
|
||||||
=> Parser term -- ^ A parser.
|
=> Parser term -- ^ A parser.
|
||||||
-> Maybe File -- ^ Prelude (optional).
|
-> Maybe File -- ^ Prelude (optional).
|
||||||
-> Project -- ^ Project to parse into a package.
|
-> Project -- ^ Project to parse into a package.
|
||||||
@ -87,11 +87,11 @@ parsePackage parser preludeFile project@Project{..} = do
|
|||||||
n = name (projectName project)
|
n = name (projectName project)
|
||||||
|
|
||||||
-- | Parse all files in a project into 'Module's.
|
-- | Parse all files in a project into 'Module's.
|
||||||
parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> Project -> Eff effs [Module term]
|
parseModules :: Member (Distribute WrappedTask) effs => Parser term -> Project -> Eff effs [Module term]
|
||||||
parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir))
|
parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir))
|
||||||
|
|
||||||
-- | Parse a file into a 'Module'.
|
-- | Parse a file into a 'Module'.
|
||||||
parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> File -> Eff effs (Module term)
|
parseModule :: (Member Files effs, Member Task effs) => Parser term -> Maybe FilePath -> File -> Eff effs (Module term)
|
||||||
parseModule parser rootDir file = do
|
parseModule parser rootDir file = do
|
||||||
blob <- readBlob file
|
blob <- readBlob file
|
||||||
moduleForBlob rootDir blob <$> parse parser blob
|
moduleForBlob rootDir blob <$> parse parser blob
|
||||||
@ -100,8 +100,8 @@ parseModule parser rootDir file = do
|
|||||||
withTermSpans :: ( HasField fields Span
|
withTermSpans :: ( HasField fields Span
|
||||||
, Member (Reader Span) effects
|
, Member (Reader Span) effects
|
||||||
)
|
)
|
||||||
=> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term location value effects a)
|
=> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
|
||||||
-> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term location value effects a)
|
-> SubtermAlgebra (TermF syntax (Record fields)) term (TermEvaluator term address value effects a)
|
||||||
withTermSpans recur term = withCurrentSpan (getField (termFAnnotation term)) (recur term)
|
withTermSpans recur term = withCurrentSpan (getField (termFAnnotation term)) (recur term)
|
||||||
|
|
||||||
resumingResolutionError :: (Applicative (m effects), Effectful m, Member Trace effects) => m (Resumable ResolutionError ': effects) a -> m effects a
|
resumingResolutionError :: (Applicative (m effects), Effectful m, Member Trace effects) => m (Resumable ResolutionError ': effects) a -> m effects a
|
||||||
@ -109,10 +109,10 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr
|
|||||||
NotFoundError nameToResolve _ _ -> pure nameToResolve
|
NotFoundError nameToResolve _ _ -> pure nameToResolve
|
||||||
GoImportError pathToResolve -> pure [pathToResolve])
|
GoImportError pathToResolve -> pure [pathToResolve])
|
||||||
|
|
||||||
resumingLoadError :: Member Trace effects => Evaluator location value (Resumable (LoadError location value) ': effects) a -> Evaluator location value effects a
|
resumingLoadError :: Member Trace effects => Evaluator address value (Resumable (LoadError address value) ': effects) a -> Evaluator address value effects a
|
||||||
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> Nothing)
|
resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> Nothing)
|
||||||
|
|
||||||
resumingEvalError :: Member Trace effects => Evaluator location value (Resumable EvalError ': effects) a -> Evaluator location value effects a
|
resumingEvalError :: Member Trace effects => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a
|
||||||
resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of
|
resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of
|
||||||
DefaultExportError{} -> pure ()
|
DefaultExportError{} -> pure ()
|
||||||
ExportError{} -> pure ()
|
ExportError{} -> pure ()
|
||||||
@ -121,15 +121,15 @@ resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *
|
|||||||
RationalFormatError{} -> pure 0
|
RationalFormatError{} -> pure 0
|
||||||
FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
|
FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
|
||||||
|
|
||||||
resumingUnspecialized :: (Member Trace effects, AbstractHole value) => Evaluator location value (Resumable (Unspecialized value) ': effects) a -> Evaluator location value effects a
|
resumingUnspecialized :: (Member Trace effects, AbstractHole value) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a
|
||||||
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> Rval hole)
|
resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> Rval hole)
|
||||||
|
|
||||||
resumingAddressError :: (AbstractHole value, Lower (Cell location value), Member Trace effects, Show location) => Evaluator location value (Resumable (AddressError location value) ': effects) a -> Evaluator location value effects a
|
resumingAddressError :: (AbstractHole value, Lower (Cell address value), Member Trace effects, Show address) => Evaluator address value (Resumable (AddressError address value) ': effects) a -> Evaluator address value effects a
|
||||||
resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> show err) *> case err of
|
resumingAddressError = runAddressErrorWith (\ err -> trace ("AddressError:" <> show err) *> case err of
|
||||||
UnallocatedAddress _ -> pure lowerBound
|
UnallocatedAddress _ -> pure lowerBound
|
||||||
UninitializedAddress _ -> pure hole)
|
UninitializedAddress _ -> pure hole)
|
||||||
|
|
||||||
resumingValueError :: (Members '[State (Environment location), Trace] effects, Show location) => Evaluator location (Value location) (Resumable (ValueError location) ': effects) a -> Evaluator location (Value location) effects a
|
resumingValueError :: (Member (State (Environment address)) effects, Member Trace effects, Show address) => Evaluator address (Value address body) (Resumable (ValueError address body) ': effects) a -> Evaluator address (Value address body) effects a
|
||||||
resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of
|
resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err) *> case err of
|
||||||
CallError val -> pure val
|
CallError val -> pure val
|
||||||
StringError val -> pure (pack (show val))
|
StringError val -> pure (pack (show val))
|
||||||
@ -145,7 +145,7 @@ resumingValueError = runValueErrorWith (\ err -> trace ("ValueError" <> show err
|
|||||||
KeyValueError{} -> pure (hole, hole)
|
KeyValueError{} -> pure (hole, hole)
|
||||||
ArithmeticError{} -> pure hole)
|
ArithmeticError{} -> pure hole)
|
||||||
|
|
||||||
resumingEnvironmentError :: AbstractHole value => Evaluator location value (Resumable (EnvironmentError value) ': effects) a -> Evaluator location value effects (a, [Name])
|
resumingEnvironmentError :: AbstractHole address => Evaluator address value (Resumable (EnvironmentError address) ': effects) a -> Evaluator address value effects (a, [Name])
|
||||||
resumingEnvironmentError
|
resumingEnvironmentError
|
||||||
= runState []
|
= runState []
|
||||||
. reinterpret (\ (Resumable (FreeVariable name)) -> modify' (name :) $> hole)
|
. reinterpret (\ (Resumable (FreeVariable name)) -> modify' (name :) $> hole)
|
||||||
|
@ -252,7 +252,7 @@ data Files out where
|
|||||||
Write :: Destination -> B.Builder -> Files ()
|
Write :: Destination -> B.Builder -> Files ()
|
||||||
|
|
||||||
-- | Run a 'Files' effect in 'IO'.
|
-- | Run a 'Files' effect in 'IO'.
|
||||||
runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a
|
runFiles :: (Member (Exc SomeException) effs, Member IO effs) => Eff (Files ': effs) a -> Eff effs a
|
||||||
runFiles = interpret $ \ files -> case files of
|
runFiles = interpret $ \ files -> case files of
|
||||||
Read (FromPath path) -> rethrowing (readBlobFromPath path)
|
Read (FromPath path) -> rethrowing (readBlobFromPath path)
|
||||||
Read (FromHandle handle) -> rethrowing (readBlobsFromHandle handle)
|
Read (FromHandle handle) -> rethrowing (readBlobsFromHandle handle)
|
||||||
|
@ -18,7 +18,7 @@ import Semantic.IO (noLanguageForBlob)
|
|||||||
import Semantic.Task
|
import Semantic.Task
|
||||||
import Serializing.Format
|
import Serializing.Format
|
||||||
|
|
||||||
runParse :: Members '[Distribute WrappedTask, Task, Exc SomeException] effs => TermRenderer output -> [Blob] -> Eff effs Builder
|
runParse :: (Member (Distribute WrappedTask) effs, Member Task effs) => TermRenderer output -> [Blob] -> Eff effs Builder
|
||||||
runParse JSONTermRenderer = withParsedBlobs (\ blob -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)) >=> serialize JSON
|
runParse JSONTermRenderer = withParsedBlobs (\ blob -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)) >=> serialize JSON
|
||||||
runParse SExpressionTermRenderer = withParsedBlobs (const (serialize (SExpression ByConstructorName)))
|
runParse SExpressionTermRenderer = withParsedBlobs (const (serialize (SExpression ByConstructorName)))
|
||||||
runParse ShowTermRenderer = withParsedBlobs (const (serialize Show))
|
runParse ShowTermRenderer = withParsedBlobs (const (serialize Show))
|
||||||
@ -27,8 +27,8 @@ runParse ImportsTermRenderer = withParsedBlobs (\ blob -> decorate (dec
|
|||||||
runParse (SymbolsTermRenderer fields) = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
|
runParse (SymbolsTermRenderer fields) = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
|
||||||
runParse DOTTermRenderer = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
|
runParse DOTTermRenderer = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
|
||||||
|
|
||||||
withParsedBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Monoid output) => (forall syntax . (ConstructorName syntax, Foldable syntax, Functor syntax, HasDeclaration syntax, HasPackageDef syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax) => Blob -> Term syntax (Record Location) -> TaskEff output) -> [Blob] -> Eff effs output
|
withParsedBlobs :: (Member (Distribute WrappedTask) effs, Monoid output) => (forall syntax . (ConstructorName syntax, Foldable syntax, Functor syntax, HasDeclaration syntax, HasPackageDef syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax) => Blob -> Term syntax (Record Location) -> TaskEff output) -> [Blob] -> Eff effs output
|
||||||
withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob)))
|
withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob)))
|
||||||
|
|
||||||
parseSomeBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, IdentifierName, Show1, ToJSONFields1] (Record Location))
|
parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, IdentifierName, Show1, ToJSONFields1] (Record Location))
|
||||||
parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) blobLanguage
|
parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) blobLanguage
|
||||||
|
@ -39,7 +39,7 @@ data Resolution output where
|
|||||||
NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution (Map FilePath FilePath)
|
NodeJSResolution :: FilePath -> Text -> [FilePath] -> Resolution (Map FilePath FilePath)
|
||||||
NoResolution :: Resolution (Map FilePath FilePath)
|
NoResolution :: Resolution (Map FilePath FilePath)
|
||||||
|
|
||||||
runResolution :: Members '[Files] effs => Eff (Resolution ': effs) a -> Eff effs a
|
runResolution :: Member Files effs => Eff (Resolution ': effs) a -> Eff effs a
|
||||||
runResolution = interpret $ \ res -> case res of
|
runResolution = interpret $ \ res -> case res of
|
||||||
NodeJSResolution dir prop excludeDirs -> nodeJSResolutionMap dir prop excludeDirs
|
NodeJSResolution dir prop excludeDirs -> nodeJSResolutionMap dir prop excludeDirs
|
||||||
NoResolution -> pure Map.empty
|
NoResolution -> pure Map.empty
|
||||||
|
@ -104,7 +104,7 @@ parse :: Member Task effs => Parser term -> Blob -> Eff effs term
|
|||||||
parse parser = send . Parse parser
|
parse parser = send . Parse parser
|
||||||
|
|
||||||
-- | A task running some 'Analysis.TermEvaluator' to completion.
|
-- | A task running some 'Analysis.TermEvaluator' to completion.
|
||||||
analyze :: Member Task effs => (Analysis.TermEvaluator term location value effects a -> result) -> Analysis.TermEvaluator term location value effects a -> Eff effs result
|
analyze :: Member Task effs => (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Eff effs result
|
||||||
analyze interpret analysis = send (Analyze interpret analysis)
|
analyze interpret analysis = send (Analyze interpret analysis)
|
||||||
|
|
||||||
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
|
-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
|
||||||
@ -112,7 +112,7 @@ decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f (Record fields))
|
|||||||
decorate algebra = send . Decorate algebra
|
decorate algebra = send . Decorate algebra
|
||||||
|
|
||||||
-- | A task which diffs a pair of terms using the supplied 'Differ' function.
|
-- | A task which diffs a pair of terms using the supplied 'Differ' function.
|
||||||
diff :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax, Member Task effs) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Eff effs (Diff syntax (Record fields1) (Record fields2))
|
diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task effs) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Eff effs (Diff syntax (Record fields1) (Record fields2))
|
||||||
diff terms = send (Semantic.Task.Diff terms)
|
diff terms = send (Semantic.Task.Diff terms)
|
||||||
|
|
||||||
-- | A task which renders some input using the supplied 'Renderer' function.
|
-- | A task which renders some input using the supplied 'Renderer' function.
|
||||||
@ -160,14 +160,14 @@ runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])
|
|||||||
-- | An effect describing high-level tasks to be performed.
|
-- | An effect describing high-level tasks to be performed.
|
||||||
data Task output where
|
data Task output where
|
||||||
Parse :: Parser term -> Blob -> Task term
|
Parse :: Parser term -> Blob -> Task term
|
||||||
Analyze :: (Analysis.TermEvaluator term location value effects a -> result) -> Analysis.TermEvaluator term location value effects a -> Task result
|
Analyze :: (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Task result
|
||||||
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
|
Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
|
||||||
Diff :: (Diffable syntax, Eq1 syntax, GAlign syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task (Diff syntax (Record fields1) (Record fields2))
|
Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task (Diff syntax (Record fields1) (Record fields2))
|
||||||
Render :: Renderer input output -> input -> Task output
|
Render :: Renderer input output -> input -> Task output
|
||||||
Serialize :: Format input -> input -> Task Builder
|
Serialize :: Format input -> input -> Task Builder
|
||||||
|
|
||||||
-- | Run a 'Task' effect by performing the actions in 'IO'.
|
-- | Run a 'Task' effect by performing the actions in 'IO'.
|
||||||
runTaskF :: Members '[Reader Options, Telemetry, Exc SomeException, Trace, IO] effs => Eff (Task ': effs) a -> Eff effs a
|
runTaskF :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Options) effs, Member Telemetry effs, Member Trace effs) => Eff (Task ': effs) a -> Eff effs a
|
||||||
runTaskF = interpret $ \ task -> case task of
|
runTaskF = interpret $ \ task -> case task of
|
||||||
Parse parser blob -> runParser blob parser
|
Parse parser blob -> runParser blob parser
|
||||||
Analyze interpret analysis -> pure (interpret analysis)
|
Analyze interpret analysis -> pure (interpret analysis)
|
||||||
@ -191,7 +191,7 @@ defaultTimeout :: Timeout
|
|||||||
defaultTimeout = Milliseconds 5000
|
defaultTimeout = Milliseconds 5000
|
||||||
|
|
||||||
-- | Parse a 'Blob' in 'IO'.
|
-- | Parse a 'Blob' in 'IO'.
|
||||||
runParser :: Members '[Reader Options, Telemetry, Exc SomeException, IO, Trace] effs => Blob -> Parser term -> Eff effs term
|
runParser :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Options) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term
|
||||||
runParser blob@Blob{..} parser = case parser of
|
runParser blob@Blob{..} parser = case parser of
|
||||||
ASTParser language ->
|
ASTParser language ->
|
||||||
time "parse.tree_sitter_ast_parse" languageTag $
|
time "parse.tree_sitter_ast_parse" languageTag $
|
||||||
|
@ -23,7 +23,7 @@ writeStat :: Member Telemetry effs => Stat -> Eff effs ()
|
|||||||
writeStat stat = send (WriteStat stat)
|
writeStat stat = send (WriteStat stat)
|
||||||
|
|
||||||
-- | A task which measures and stats the timing of another task.
|
-- | A task which measures and stats the timing of another task.
|
||||||
time :: Members '[Telemetry, IO] effs => String -> [(String, String)] -> Eff effs output -> Eff effs output
|
time :: (Member IO effs, Member Telemetry effs) => String -> [(String, String)] -> Eff effs output -> Eff effs output
|
||||||
time statName tags task = do
|
time statName tags task = do
|
||||||
(a, stat) <- withTiming statName tags task
|
(a, stat) <- withTiming statName tags task
|
||||||
a <$ writeStat stat
|
a <$ writeStat stat
|
||||||
|
@ -27,7 +27,7 @@ import Semantic.Graph
|
|||||||
import Semantic.IO as IO
|
import Semantic.IO as IO
|
||||||
import Semantic.Task
|
import Semantic.Task
|
||||||
import Text.Show (showListWith)
|
import Text.Show (showListWith)
|
||||||
import Text.Show.Pretty
|
import Text.Show.Pretty (ppShow)
|
||||||
|
|
||||||
import qualified Language.Python.Assignment as Python
|
import qualified Language.Python.Assignment as Python
|
||||||
import qualified Language.Ruby.Assignment as Ruby
|
import qualified Language.Ruby.Assignment as Ruby
|
||||||
@ -39,26 +39,13 @@ justEvaluating
|
|||||||
. evaluating
|
. evaluating
|
||||||
. runPrintingTrace
|
. runPrintingTrace
|
||||||
. runLoadError
|
. runLoadError
|
||||||
. runValueError
|
|
||||||
. runUnspecialized
|
. runUnspecialized
|
||||||
. runResolutionError
|
. runResolutionError
|
||||||
. runEnvironmentError
|
. runEnvironmentError
|
||||||
. runEvalError
|
. runEvalError
|
||||||
. runAddressError
|
. runAddressError
|
||||||
. runTermEvaluator @_ @Precise
|
. runTermEvaluator @_ @Precise @(Value Precise (Eff _))
|
||||||
|
. runValueError
|
||||||
evaluatingWithHoles
|
|
||||||
= runM
|
|
||||||
. evaluating
|
|
||||||
. runPrintingTrace
|
|
||||||
. resumingLoadError
|
|
||||||
. resumingUnspecialized
|
|
||||||
. resumingValueError
|
|
||||||
. resumingEnvironmentError
|
|
||||||
. resumingEvalError
|
|
||||||
. resumingResolutionError
|
|
||||||
. resumingAddressError
|
|
||||||
. runTermEvaluator @_ @Precise
|
|
||||||
|
|
||||||
checking
|
checking
|
||||||
= runM @_ @IO
|
= runM @_ @IO
|
||||||
@ -80,7 +67,6 @@ evalRubyProject path = justEvaluating =<< evaluateProject rubyParser Language.Ru
|
|||||||
evalPHPProject path = justEvaluating =<< evaluateProject phpParser Language.PHP Nothing path
|
evalPHPProject path = justEvaluating =<< evaluateProject phpParser Language.PHP Nothing path
|
||||||
evalPythonProject path = justEvaluating =<< evaluateProject pythonParser Language.Python pythonPrelude path
|
evalPythonProject path = justEvaluating =<< evaluateProject pythonParser Language.Python pythonPrelude path
|
||||||
evalJavaScriptProject path = justEvaluating =<< evaluateProject typescriptParser Language.JavaScript javaScriptPrelude path
|
evalJavaScriptProject path = justEvaluating =<< evaluateProject typescriptParser Language.JavaScript javaScriptPrelude path
|
||||||
evalTypeScriptProjectQuietly path = evaluatingWithHoles =<< evaluateProject typescriptParser Language.TypeScript Nothing path
|
|
||||||
evalTypeScriptProject path = justEvaluating =<< evaluateProject typescriptParser Language.TypeScript Nothing path
|
evalTypeScriptProject path = justEvaluating =<< evaluateProject typescriptParser Language.TypeScript Nothing path
|
||||||
|
|
||||||
typecheckGoFile path = checking =<< evaluateProjectWithCaching goParser Language.Go Nothing path
|
typecheckGoFile path = checking =<< evaluateProjectWithCaching goParser Language.Go Nothing path
|
||||||
|
@ -1,11 +1,9 @@
|
|||||||
{-# LANGUAGE OverloadedLists #-}
|
|
||||||
module Analysis.Go.Spec (spec) where
|
module Analysis.Go.Spec (spec) where
|
||||||
|
|
||||||
import Data.Abstract.Environment as Env
|
import Data.Abstract.Environment as Env
|
||||||
import Data.Abstract.Evaluatable (EvalError(..))
|
import Data.Abstract.Evaluatable (EvalError(..))
|
||||||
import qualified Language.Go.Assignment as Go
|
|
||||||
import qualified Data.Language as Language
|
import qualified Data.Language as Language
|
||||||
|
import qualified Language.Go.Assignment as Go
|
||||||
import SpecHelpers
|
import SpecHelpers
|
||||||
|
|
||||||
|
|
||||||
|
@ -1,11 +1,10 @@
|
|||||||
{-# LANGUAGE OverloadedLists #-}
|
|
||||||
module Analysis.PHP.Spec (spec) where
|
module Analysis.PHP.Spec (spec) where
|
||||||
|
|
||||||
|
import Control.Abstract
|
||||||
import Data.Abstract.Environment as Env
|
import Data.Abstract.Environment as Env
|
||||||
import Data.Abstract.Evaluatable (EvalError(..))
|
import Data.Abstract.Evaluatable (EvalError(..))
|
||||||
import qualified Language.PHP.Assignment as PHP
|
|
||||||
import qualified Data.Language as Language
|
import qualified Data.Language as Language
|
||||||
|
import qualified Language.PHP.Assignment as PHP
|
||||||
import SpecHelpers
|
import SpecHelpers
|
||||||
|
|
||||||
|
|
||||||
@ -13,12 +12,14 @@ spec :: Spec
|
|||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
describe "PHP" $ do
|
describe "PHP" $ do
|
||||||
it "evaluates include and require" $ do
|
it "evaluates include and require" $ do
|
||||||
env <- environment . snd . fst <$> evaluate "main.php"
|
((res, state), _) <- evaluate "main.php"
|
||||||
Env.names env `shouldBe` [ "bar", "foo" ]
|
res `shouldBe` Right [unit]
|
||||||
|
Env.names (environment state) `shouldBe` [ "bar", "foo" ]
|
||||||
|
|
||||||
it "evaluates include_once and require_once" $ do
|
it "evaluates include_once and require_once" $ do
|
||||||
env <- environment . snd . fst <$> evaluate "main_once.php"
|
((res, state), _) <- evaluate "main_once.php"
|
||||||
Env.names env `shouldBe` [ "bar", "foo" ]
|
res `shouldBe` Right [unit]
|
||||||
|
Env.names (environment state) `shouldBe` [ "bar", "foo" ]
|
||||||
|
|
||||||
it "evaluates namespaces" $ do
|
it "evaluates namespaces" $ do
|
||||||
((_, state), _) <- evaluate "namespaces.php"
|
((_, state), _) <- evaluate "namespaces.php"
|
||||||
|
@ -1,4 +1,3 @@
|
|||||||
{-# LANGUAGE OverloadedLists, OverloadedStrings #-}
|
|
||||||
module Analysis.Python.Spec (spec) where
|
module Analysis.Python.Spec (spec) where
|
||||||
|
|
||||||
import Data.Abstract.Environment as Env
|
import Data.Abstract.Environment as Env
|
||||||
@ -45,7 +44,6 @@ spec = parallel $ do
|
|||||||
|
|
||||||
where
|
where
|
||||||
ns n = Just . Latest . Last . Just . Namespace n
|
ns n = Just . Latest . Last . Just . Namespace n
|
||||||
addr = Address . Precise
|
|
||||||
fixtures = "test/fixtures/python/analysis/"
|
fixtures = "test/fixtures/python/analysis/"
|
||||||
evaluate entry = evalPythonProject (fixtures <> entry)
|
evaluate entry = evalPythonProject (fixtures <> entry)
|
||||||
evalPythonProject path = testEvaluating <$> evaluateProject pythonParser Language.Python pythonPrelude path
|
evalPythonProject path = testEvaluating <$> evaluateProject pythonParser Language.Python pythonPrelude path
|
||||||
|
@ -1,11 +1,10 @@
|
|||||||
{-# LANGUAGE OverloadedLists #-}
|
|
||||||
|
|
||||||
module Analysis.Ruby.Spec (spec) where
|
module Analysis.Ruby.Spec (spec) where
|
||||||
|
|
||||||
import Data.Abstract.Environment as Env
|
import Data.Abstract.Environment as Env
|
||||||
import Data.Abstract.Evaluatable
|
import Data.Abstract.Evaluatable
|
||||||
import Data.Abstract.Value as Value
|
import Data.Abstract.Value as Value
|
||||||
import Data.Abstract.Number as Number
|
import Data.Abstract.Number as Number
|
||||||
|
import Data.AST
|
||||||
import Control.Monad.Effect (SomeExc(..))
|
import Control.Monad.Effect (SomeExc(..))
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
import Data.Map
|
import Data.Map
|
||||||
@ -31,7 +30,7 @@ spec = parallel $ do
|
|||||||
|
|
||||||
it "evaluates load with wrapper" $ do
|
it "evaluates load with wrapper" $ do
|
||||||
((res, state), _) <- evaluate "load-wrap.rb"
|
((res, state), _) <- evaluate "load-wrap.rb"
|
||||||
res `shouldBe` Left (SomeExc (inject @(EnvironmentError (Value Precise)) (FreeVariable "foo")))
|
res `shouldBe` Left (SomeExc (inject @(EnvironmentError Precise) (FreeVariable "foo")))
|
||||||
Env.names (environment state) `shouldContain` [ "Object" ]
|
Env.names (environment state) `shouldContain` [ "Object" ]
|
||||||
|
|
||||||
it "evaluates subclass" $ do
|
it "evaluates subclass" $ do
|
||||||
@ -77,7 +76,6 @@ spec = parallel $ do
|
|||||||
|
|
||||||
where
|
where
|
||||||
ns n = Just . Latest . Last . Just . Namespace n
|
ns n = Just . Latest . Last . Just . Namespace n
|
||||||
addr = Address . Precise
|
|
||||||
fixtures = "test/fixtures/ruby/analysis/"
|
fixtures = "test/fixtures/ruby/analysis/"
|
||||||
evaluate entry = evalRubyProject (fixtures <> entry)
|
evaluate entry = evalRubyProject (fixtures <> entry)
|
||||||
evalRubyProject path = testEvaluating <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
|
evalRubyProject path = testEvaluating <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
|
||||||
|
@ -1,4 +1,3 @@
|
|||||||
{-# LANGUAGE OverloadedLists #-}
|
|
||||||
module Analysis.TypeScript.Spec (spec) where
|
module Analysis.TypeScript.Spec (spec) where
|
||||||
|
|
||||||
import Control.Arrow ((&&&))
|
import Control.Arrow ((&&&))
|
||||||
|
@ -19,32 +19,27 @@ import SpecHelpers hiding (reassociate)
|
|||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = parallel $ do
|
spec = parallel $ do
|
||||||
it "constructs integers" $ do
|
it "constructs integers" $ do
|
||||||
(expected, _) <- evaluate (integer 123)
|
(expected, _) <- evaluate (pure (integer 123))
|
||||||
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
||||||
|
|
||||||
it "calls functions" $ do
|
it "calls functions" $ do
|
||||||
(expected, _) <- evaluate $ do
|
(expected, _) <- evaluate $ do
|
||||||
identity <- closure [name "x"] lowerBound (variable (name "x"))
|
identity <- closure [name "x"] lowerBound (variable (name "x"))
|
||||||
call identity [integer 123]
|
call identity [pure (integer 123)]
|
||||||
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
||||||
|
|
||||||
evaluate
|
evaluate
|
||||||
= runM
|
= runM
|
||||||
. fmap (first reassociate)
|
. fmap (first reassociate)
|
||||||
. evaluating @Precise @(Value Precise)
|
. evaluating @Precise @(Value Precise (Eff _))
|
||||||
. runReader (PackageInfo (name "test") Nothing mempty)
|
. runReader (PackageInfo (name "test") Nothing mempty)
|
||||||
. runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
|
. runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
|
||||||
. Value.runValueError
|
. runValueError
|
||||||
. runEnvironmentError
|
. runEnvironmentError
|
||||||
. runAddressError
|
. runAddressError
|
||||||
. runAllocator
|
. runAllocator
|
||||||
. runReturn
|
. runReturn
|
||||||
. runLoopControl
|
. runLoopControl
|
||||||
. fmap fst
|
|
||||||
. runState (Gotos lowerBound)
|
|
||||||
. runGoto Gotos getGotos
|
|
||||||
|
|
||||||
newtype Gotos effects = Gotos { getGotos :: GotoTable (State (Gotos effects) ': effects) (Value Precise) }
|
|
||||||
|
|
||||||
reassociate :: Either Prelude.String (Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result))) -> Either (SomeExc (Sum '[Const Prelude.String, exc1, exc2, exc3])) result
|
reassociate :: Either Prelude.String (Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result))) -> Either (SomeExc (Sum '[Const Prelude.String, exc1, exc2, exc3])) result
|
||||||
reassociate (Left s) = Left (SomeExc (inject (Const s)))
|
reassociate (Left s) = Left (SomeExc (inject (Const s)))
|
||||||
|
@ -1,61 +0,0 @@
|
|||||||
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
|
|
||||||
module Data.Mergeable.Spec (spec) where
|
|
||||||
|
|
||||||
import Control.Applicative (Alternative(..))
|
|
||||||
import Data.Functor.Identity
|
|
||||||
import Data.Functor.Listable
|
|
||||||
import Data.Maybe (catMaybes)
|
|
||||||
import Data.Mergeable
|
|
||||||
import Test.Hspec
|
|
||||||
import Test.Hspec.LeanCheck
|
|
||||||
import Test.LeanCheck
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = parallel $ do
|
|
||||||
describe "[]" $ do
|
|
||||||
withAlternativeInstances sequenceAltLaws (tiers :: [Tier String])
|
|
||||||
withAlternativeInstances mergeLaws (tiers :: [Tier String])
|
|
||||||
describe "Maybe" $ do
|
|
||||||
withAlternativeInstances sequenceAltLaws (tiers :: [Tier (Maybe Char)])
|
|
||||||
withAlternativeInstances mergeLaws (tiers :: [Tier (Maybe Char)])
|
|
||||||
describe "Identity" $ do
|
|
||||||
withAlternativeInstances sequenceAltLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
|
|
||||||
withAlternativeInstances mergeLaws (Identity `mapT` tiers :: [Tier (Identity Char)])
|
|
||||||
describe "ListableSyntax" $ do
|
|
||||||
withAlternativeInstances sequenceAltLaws (tiers :: [Tier (ListableSyntax Char)])
|
|
||||||
withAlternativeInstances mergeLaws (tiers :: [Tier (ListableSyntax Char)])
|
|
||||||
|
|
||||||
prop "subsumes catMaybes/Just" $
|
|
||||||
\ a -> sequenceAlt a `shouldBe` pure (catMaybes (a :: [Maybe Char]))
|
|
||||||
|
|
||||||
mergeLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => [Tier (f a)] -> [Tier (Blind (a -> g a))] -> Spec
|
|
||||||
mergeLaws value function = describe "merge" $ do
|
|
||||||
prop "identity" . forAll value $
|
|
||||||
\ a -> merge pure a `shouldNotBe` (empty :: g (f a))
|
|
||||||
|
|
||||||
prop "relationship with sequenceAlt" . forAll (value >< function) $
|
|
||||||
\ (a, f) -> merge (getBlind f) a `shouldBe` sequenceAlt (fmap (getBlind f) a)
|
|
||||||
|
|
||||||
sequenceAltLaws :: forall f g a. (Mergeable f, Alternative g, Eq (g (f a)), Show (f a), Show (g (f a))) => [Tier (f a)] -> [Tier (Blind (a -> g a))] -> Spec
|
|
||||||
sequenceAltLaws value function = describe "sequenceAlt" $ do
|
|
||||||
prop "identity" . forAll value $
|
|
||||||
\ a -> sequenceAlt (pure <$> a) `shouldNotBe` (empty :: g (f a))
|
|
||||||
|
|
||||||
prop "relationship with merge" . forAll (productWith ((Blind .) . fmap . getBlind) function value :: [Tier (Blind (f (g a)))]) $
|
|
||||||
\ a -> sequenceAlt (getBlind a) `shouldBe` merge id (getBlind a)
|
|
||||||
|
|
||||||
|
|
||||||
withAlternativeInstances :: forall f a. (Listable a, Eq (f a), Show (f a)) => (forall g. (Alternative g, Eq (g (f a)), Show (g (f a))) => [Tier (f a)] -> [Tier (Blind (a -> g a))] -> Spec) -> [Tier (f a)] -> Spec
|
|
||||||
withAlternativeInstances laws gen = do
|
|
||||||
describe "[]" $ laws gen (fmap const `mapT` tiers :: [Tier (Blind (a -> [a]))])
|
|
||||||
describe "Maybe" $ laws gen (fmap const `mapT` tiers :: [Tier (Blind (a -> Maybe a))])
|
|
||||||
|
|
||||||
|
|
||||||
newtype Blind a = Blind { getBlind :: a }
|
|
||||||
deriving Functor
|
|
||||||
|
|
||||||
instance Listable a => Listable (Blind a) where
|
|
||||||
tiers = Blind `mapT` tiers
|
|
||||||
|
|
||||||
instance Show (Blind a) where
|
|
||||||
showsPrec _ _ = showString "*"
|
|
@ -6,7 +6,8 @@ import System.Environment
|
|||||||
import Test.DocTest
|
import Test.DocTest
|
||||||
|
|
||||||
defaultFiles =
|
defaultFiles =
|
||||||
[ "src/Data/Abstract/Environment.hs"
|
[ "src/Data/Abstract/Address.hs"
|
||||||
|
, "src/Data/Abstract/Environment.hs"
|
||||||
, "src/Data/Abstract/Name.hs"
|
, "src/Data/Abstract/Name.hs"
|
||||||
, "src/Data/Range.hs"
|
, "src/Data/Range.hs"
|
||||||
, "src/Data/Semigroup/App.hs"
|
, "src/Data/Semigroup/App.hs"
|
||||||
|
@ -3,7 +3,6 @@ module Rendering.TOC.Spec (spec) where
|
|||||||
|
|
||||||
import Analysis.Declaration
|
import Analysis.Declaration
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Align.Generic
|
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Bifunctor.Join
|
import Data.Bifunctor.Join
|
||||||
import Data.Diff
|
import Data.Diff
|
||||||
@ -240,10 +239,10 @@ diffWithParser :: ( HasField fields Data.Span.Span
|
|||||||
, Show1 syntax
|
, Show1 syntax
|
||||||
, Traversable syntax
|
, Traversable syntax
|
||||||
, Diffable syntax
|
, Diffable syntax
|
||||||
, GAlign syntax
|
|
||||||
, HasDeclaration syntax
|
, HasDeclaration syntax
|
||||||
, Hashable1 syntax
|
, Hashable1 syntax
|
||||||
, Members '[Distribute WrappedTask, Task] effs
|
, Member (Distribute WrappedTask) effs
|
||||||
|
, Member Task effs
|
||||||
)
|
)
|
||||||
=> Parser (Term syntax (Record fields))
|
=> Parser (Term syntax (Record fields))
|
||||||
-> BlobPair
|
-> BlobPair
|
||||||
|
@ -10,7 +10,6 @@ import qualified Control.Abstract.Evaluator.Spec
|
|||||||
import qualified Data.Diff.Spec
|
import qualified Data.Diff.Spec
|
||||||
import qualified Data.Abstract.Path.Spec
|
import qualified Data.Abstract.Path.Spec
|
||||||
import qualified Data.Functor.Classes.Generic.Spec
|
import qualified Data.Functor.Classes.Generic.Spec
|
||||||
import qualified Data.Mergeable.Spec
|
|
||||||
import qualified Data.Scientific.Spec
|
import qualified Data.Scientific.Spec
|
||||||
import qualified Data.Source.Spec
|
import qualified Data.Source.Spec
|
||||||
import qualified Data.Term.Spec
|
import qualified Data.Term.Spec
|
||||||
@ -40,7 +39,6 @@ main = hspec $ do
|
|||||||
describe "Data.Diff" Data.Diff.Spec.spec
|
describe "Data.Diff" Data.Diff.Spec.spec
|
||||||
describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
|
describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
|
||||||
describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
|
describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
|
||||||
describe "Data.Mergeable" Data.Mergeable.Spec.spec
|
|
||||||
describe "Data.Scientific" Data.Scientific.Spec.spec
|
describe "Data.Scientific" Data.Scientific.Spec.spec
|
||||||
describe "Data.Source" Data.Source.Spec.spec
|
describe "Data.Source" Data.Source.Spec.spec
|
||||||
describe "Data.Term" Data.Term.Spec.spec
|
describe "Data.Term" Data.Term.Spec.spec
|
||||||
|
@ -8,6 +8,7 @@ module SpecHelpers
|
|||||||
, deNamespace
|
, deNamespace
|
||||||
, derefQName
|
, derefQName
|
||||||
, verbatim
|
, verbatim
|
||||||
|
, TermEvaluator(..)
|
||||||
, Verbatim(..)
|
, Verbatim(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -83,23 +84,23 @@ testEvaluating
|
|||||||
. fmap (first reassociate)
|
. fmap (first reassociate)
|
||||||
. evaluating
|
. evaluating
|
||||||
. runLoadError
|
. runLoadError
|
||||||
. runValueError
|
|
||||||
. runUnspecialized
|
. runUnspecialized
|
||||||
. runResolutionError
|
. runResolutionError
|
||||||
. runEnvironmentError
|
. runEnvironmentError
|
||||||
. runEvalError
|
. runEvalError
|
||||||
. runAddressError
|
. runAddressError
|
||||||
. runTermEvaluator @_ @Precise
|
. runValueError
|
||||||
|
. runTermEvaluator @_ @_ @(Value Precise (Eff _))
|
||||||
|
|
||||||
deNamespace :: Value Precise -> Maybe (Name, [Name])
|
deNamespace :: Value Precise term -> Maybe (Name, [Name])
|
||||||
deNamespace (Namespace name scope) = Just (name, Env.names scope)
|
deNamespace (Namespace name scope) = Just (name, Env.names scope)
|
||||||
deNamespace _ = Nothing
|
deNamespace _ = Nothing
|
||||||
|
|
||||||
namespaceScope :: Value Precise -> Maybe (Environment Precise)
|
namespaceScope :: Value Precise term -> Maybe (Environment Precise)
|
||||||
namespaceScope (Namespace _ scope) = Just scope
|
namespaceScope (Namespace _ scope) = Just scope
|
||||||
namespaceScope _ = Nothing
|
namespaceScope _ = Nothing
|
||||||
|
|
||||||
derefQName :: Heap Precise (Cell Precise) (Value Precise) -> NonEmpty Name -> Environment Precise -> Maybe (Value Precise)
|
derefQName :: Heap Precise (Cell Precise) (Value Precise term) -> NonEmpty Name -> Environment Precise -> Maybe (Value Precise term)
|
||||||
derefQName heap = go
|
derefQName heap = go
|
||||||
where go (n1 :| ns) env = Env.lookup n1 env >>= flip heapLookup heap >>= getLast . unLatest >>= case ns of
|
where go (n1 :| ns) env = Env.lookup n1 env >>= flip heapLookup heap >>= getLast . unLatest >>= case ns of
|
||||||
[] -> Just
|
[] -> Just
|
||||||
|
2
vendor/effects
vendored
2
vendor/effects
vendored
@ -1 +1 @@
|
|||||||
Subproject commit 4b4f2956d8a4d5542990431a1d0a5735f48f917e
|
Subproject commit adec65af304cc31681ce02111985aa73e1f11cf5
|
Loading…
Reference in New Issue
Block a user