Merge branch 'master' into add-explicit-assignment-timeout

.licenses/semantic/cabal/fused-effects.txt

@@ -1,7 +1,7 @@
 ---
 type: cabal
 name: fused-effects
-version: 0.1.0.0
+version: 0.1.1.0
 summary: 'A fast, flexible, fused effect system, à la Effect Handlers in Scope, Monad Transformers and Modular Algebraic Effects: What Binds Them Together, and Fusion for Free—Efficient Algebraic Effect Handlers.'
 homepage: https://github.com/robrix/fused-effects
 license: bsd-3-clause

semantic.cabal

@@ -49,6 +49,7 @@ library
                      , Control.Abstract.Value
                      -- Effects
                      , Control.Effect.Interpose
+                     , Control.Effect.REPL
                      -- Matching and rewriting DSLs
                      , Control.Matching
                      , Control.Rewriting
@@ -331,12 +332,17 @@ test-suite test
                      , Assigning.Assignment.Spec
                      , Control.Abstract.Evaluator.Spec
                      , Control.Rewriting.Spec
+                     , Data.Abstract.Environment.Spec
                      , Data.Abstract.Path.Spec
+                     , Data.Abstract.Name.Spec
                      , Data.Diff.Spec
                      , Data.Functor.Classes.Generic.Spec
                      , Data.Functor.Listable
+                     , Data.Graph.Spec
                      , Data.Mergeable
+                     , Data.Range.Spec
                      , Data.Scientific.Spec
+                     , Data.Semigroup.App.Spec
                      , Data.Source.Spec
                      , Data.Term.Spec
                      , Diffing.Algorithm.RWS.Spec
@@ -428,15 +434,6 @@ test-suite parse-examples
   default-extensions:  RecordWildCards
                      , FlexibleContexts
 
-test-suite doctests
-  type:                exitcode-stdio-1.0
-  hs-source-dirs:      test
-  main-is:             Doctests.hs
-  default-language:    Haskell2010
-  ghc-options:         -dynamic -threaded -j
-  build-depends:       base
-                     , doctest
-
 benchmark evaluation
   hs-source-dirs:      bench/evaluation
   type:                exitcode-stdio-1.0

src/Control/Abstract/Modules.hs

@@ -26,7 +26,6 @@ import Data.Abstract.Environment
 import Data.Abstract.BaseError
 import Data.Abstract.Module
 import Data.Abstract.ModuleTable as ModuleTable
-import Data.Coerce
 import Data.Language
 import Data.Semigroup.Foldable (foldMap1)
 import qualified Data.Set as Set

src/Control/Abstract/Value.hs

@@ -35,7 +35,6 @@ import Control.Abstract.Environment
 import Control.Abstract.Evaluator
 import Control.Abstract.Heap
 import Control.Effect.Carrier
-import Data.Coerce
 import Data.Abstract.BaseError
 import Data.Abstract.Environment as Env
 import Data.Abstract.Module

src/Control/Effect/REPL.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-}
+
+module Control.Effect.REPL
+  ( REPL (..)
+  , REPLC (..)
+  , prompt
+  , output
+  , runREPL
+  ) where
+
+import Prologue
+
+import Control.Effect
+import Control.Effect.Carrier
+import Control.Effect.Sum
+import System.Console.Haskeline
+import qualified Data.Text as T
+
+data REPL (m :: * -> *) k
+  = Prompt Text (Maybe Text -> k)
+  | Output Text k
+  deriving (Functor)
+
+instance HFunctor REPL where
+  hmap _ = coerce
+
+instance Effect REPL where
+  handle state handler (Prompt p k) = Prompt p (handler . (<$ state) . k)
+  handle state handler (Output s k) = Output s (handler (k <$ state))
+
+prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text)
+prompt p = send (Prompt p ret)
+
+output :: (Member REPL sig, Carrier sig m) => Text -> m ()
+output s = send (Output s (ret ()))
+
+runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a
+runREPL prefs settings = flip runREPLC (prefs, settings) . interpret
+
+newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a }
+
+instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
+  ret = REPLC . const . ret
+  eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case
+    Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= flip runREPLC args . k
+    Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> runREPLC k args) op)
+
+cyan :: String
+cyan = "\ESC[1;36m\STX"
+
+plain :: String
+plain = "\ESC[0m\STX"

src/Data/Abstract/Environment.hs

@@ -33,11 +33,6 @@ import qualified Data.Map as Map
 import           Prelude hiding (head, lookup)
 import           Prologue
 
--- $setup
--- >>> import Data.Abstract.Address.Precise
--- >>> let bright = push (insertEnv (name "foo") (Precise 0) lowerBound)
--- >>> let shadowed = insertEnv (name "foo") (Precise 1) bright
-
 -- | A map of names to values. Represents a single scope level of an environment chain.
 newtype Bindings address = Bindings { unBindings :: Map.Map Name address }
   deriving stock (Eq, Ord, Generic)
@@ -119,9 +114,6 @@ lookup :: Name -> Bindings address -> Maybe address
 lookup name = Map.lookup name . unBindings
 
 -- | Lookup a 'Name' in the environment.
---
--- >>> lookupEnv' (name "foo") shadowed
--- Just (Precise 1)
 lookupEnv' :: Name -> Environment address -> Maybe address
 lookupEnv' name = foldMapA (lookup name) . unEnvironment
 
@@ -134,9 +126,6 @@ insertEnv :: Name -> address -> Environment address -> Environment address
 insertEnv name addr (Environment (Bindings a :| as)) = Environment (Bindings (Map.insert name addr a) :| as)
 
 -- | Remove a 'Name' from the environment.
---
--- >>> delete (name "foo") shadowed
--- Environment []
 delete :: Name -> Environment address -> Environment address
 delete name = trim . Environment . fmap (Bindings . Map.delete name . unBindings) . unEnvironment
 

src/Data/Abstract/Name.hs

@@ -48,17 +48,13 @@ nameI :: Int -> Name
 nameI = I
 
 -- | Extract a human-readable 'Text' from a 'Name'.
+-- Sample outputs can be found in @Data.Abstract.Name.Spec@.
 formatName :: Name -> Text
 formatName (Name name) = name
 formatName (I i)       = Text.pack $ '_' : (alphabet !! a) : replicate n 'ʹ'
   where alphabet = ['a'..'z']
         (n, a) = i `divMod` length alphabet
 
--- $
--- >>> I 0
--- "_a"
--- >>> I 26
--- "_aʹ"
 instance Show Name where
   showsPrec _ = prettyShowString . Text.unpack . formatName
     where prettyShowString str = showChar '"' . foldr ((.) . prettyChar) id str . showChar '"'

src/Data/Graph.hs

@@ -34,28 +34,7 @@ simplify :: Ord vertex => Graph vertex -> Graph vertex
 simplify (Graph graph) = Graph (G.simplify graph)
 
 
--- | Sort a graph’s vertices topologically.
+-- | Sort a graph’s vertices topologically. Specced in @Data.Graph.Spec@.
---
--- >>> topologicalSort (Class.path "ab")
--- "ba"
---
--- >>> topologicalSort (Class.path "abc")
--- "cba"
---
--- >>> topologicalSort ((vertex 'a' `connect` vertex 'b') `connect` vertex 'c')
--- "cba"
---
--- >>> topologicalSort (vertex 'a' `connect` (vertex 'b' `connect` vertex 'c'))
--- "cba"
---
--- >>> topologicalSort ((vertex 'a' `connect` vertex 'b') <> (vertex 'a' `connect` vertex 'c'))
--- "cba"
---
--- >>> topologicalSort (Class.path "abd" <> Class.path "acd")
--- "dcba"
---
--- >>> topologicalSort (Class.path "aba")
--- "ab"
 topologicalSort :: forall v . Ord v => Graph v -> [v]
 topologicalSort = go . Class.toAdjacencyMap . G.transpose . unGraph
   where go :: A.AdjacencyMap v -> [v]

src/Data/Range.hs

@@ -40,13 +40,7 @@ subtractRange range1 range2 = Range (start range1) (end range1 - rangeLength (Ra
 
 -- Instances
 
--- $setup
+-- | The associativity of this instance is specced in @Data.Range.Spec@.
--- >>> import Test.QuickCheck
--- >>> instance Arbitrary Range where arbitrary = Range <$> arbitrary <*> arbitrary
-
--- $
--- Associativity:
--- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: Range)
 instance Semigroup Range where
   Range start1 end1 <> Range start2 end2 = Range (min start1 start2) (max end1 end2)
 

src/Data/Semigroup/App.hs

@@ -6,33 +6,20 @@ module Data.Semigroup.App
 
 import Control.Applicative
 
--- $setup
--- >>> import Test.QuickCheck
--- >>> instance Arbitrary (f a) => Arbitrary (App f a) where arbitrary = App <$> arbitrary ; shrink = map App . shrink . runApp
--- >>> instance Arbitrary (f a) => Arbitrary (AppMerge f a) where arbitrary = AppMerge <$> arbitrary ; shrink = map AppMerge . shrink . runAppMerge
-
 -- | 'Semigroup' under '*>'.
 newtype App f a = App { runApp :: f a }
   deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable)
 
--- $ Associativity:
---   prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: App Maybe Integer)
 instance Applicative f => Semigroup (App f a) where
   App a <> App b = App (a *> b)
 
-
 -- | 'Semigroup' and 'Monoid' under '<*>' and '<>'.
 newtype AppMerge f a = AppMerge { runAppMerge :: f a }
   deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable)
 
--- $ Associativity:
---   prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String)
 instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where
   AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b)
 
--- $ Identity:
---   prop> \ a -> mempty <> a == (a :: AppMerge Maybe String)
---   prop> \ a -> a <> mempty == (a :: AppMerge Maybe String)
 instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where
   mempty = AppMerge (pure mempty)
   mappend = (<>)

src/Data/Syntax.hs

@@ -13,7 +13,7 @@ import Data.Sum
 import Data.Term
 import GHC.Types (Constraint)
 import GHC.TypeLits
-import Diffing.Algorithm hiding (Empty)
+import Diffing.Algorithm
 import Prelude
 import Prologue
 import Reprinting.Tokenize hiding (Element)

src/Diffing/Algorithm.hs

@@ -1,7 +1,7 @@
-{-# LANGUAGE DefaultSignatures, GADTs, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DefaultSignatures, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-}
 module Diffing.Algorithm
-  ( AlgorithmF (..)
+  ( Diff (..)
-  , Algorithm
+  , Algorithm(..)
   , Diffable (..)
   , Equivalence (..)
   , diff
@@ -14,104 +14,100 @@ module Diffing.Algorithm
   , algorithmForTerms
   ) where
 
-import Control.Monad.Free.Freer
+import Control.Effect hiding ((:+:))
-import Data.Diff
+import Control.Effect.Carrier
+import Data.Coerce (coerce)
+import qualified Data.Diff as Diff
 import Data.Sum
 import Data.Term
 import GHC.Generics
 import Prologue
 
 -- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm.
-data AlgorithmF term1 term2 result partial where
+data Diff term1 term2 diff (m :: * -> *) k
   -- | Diff two terms with the choice of algorithm left to the interpreter’s discretion.
-  Diff :: term1 -> term2 -> AlgorithmF term1 term2 result result
+  = Diff term1 term2 (diff -> k)
   -- | Diff two terms recursively in O(n) time, resulting in a single diff node.
-  Linear :: term1 -> term2 -> AlgorithmF term1 term2 result result
+  | Linear term1 term2 (diff -> k)
   -- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs.
-  RWS :: [term1] -> [term2] -> AlgorithmF term1 term2 result [result]
+  | RWS [term1] [term2] ([diff] -> k)
   -- | Delete a term.
-  Delete :: term1 -> AlgorithmF term1 term2 result result
+  | Delete term1 (diff -> k)
   -- | Insert a term.
-  Insert :: term2 -> AlgorithmF term1 term2 result result
+  | Insert term2 (diff -> k)
   -- | Replace one term with another.
-  Replace :: term1 -> term2 -> AlgorithmF term1 term2 result result
+  | Replace term1 term2 (diff -> k)
-  -- | An 'Algorithm' that always fails.
+  deriving (Functor)
-  Empty :: AlgorithmF term1 term2 result a
-  -- | An 'Algorithm' to try one of two alternatives.
-  Alt :: a -> a -> AlgorithmF term1 term2 result a
 
--- | The free(r) monad for 'AlgorithmF'. This enables us to construct algorithms to diff using '<$>', '<*>', '>>=', and do-notation.
+instance HFunctor (Diff term1 term2 diff) where
-type Algorithm term1 term2 result = Freer (AlgorithmF term1 term2 result)
+  hmap _ = coerce
+  {-# INLINE hmap #-}
+
+instance Effect (Diff term1 term2 diff) where
+  handle state handler = coerce . fmap (handler . (<$ state))
+
+
+newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: Eff m a }
+  deriving (Applicative, Functor, Monad)
+
+deriving instance (Carrier sig m, Member NonDet sig) => Alternative (Algorithm term1 term2 diff m)
+
+instance Carrier sig m => Carrier sig (Algorithm term1 term2 diff m) where
+  ret = Algorithm . ret
+  eff = Algorithm . eff . handleCoercible
 
 
 -- DSL
 
 -- | Diff two terms without specifying the algorithm to be used.
-diff :: term1 -> term2 -> Algorithm term1 term2 result result
+diff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> m diff
-diff a1 a2 = Diffing.Algorithm.Diff a1 a2 `Then` return
+diff a1 a2 = send (Diff a1 a2 ret)
 
 -- | Diff a These of terms without specifying the algorithm to be used.
-diffThese :: These term1 term2 -> Algorithm term1 term2 result result
+diffThese :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => These term1 term2 -> Algorithm term1 term2 diff m diff
 diffThese = these byDeleting byInserting diff
 
 -- | Diff a pair of optional terms without specifying the algorithm to be used.
-diffMaybe :: Maybe term1 -> Maybe term2 -> Algorithm term1 term2 result (Maybe result)
+diffMaybe :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Maybe term1 -> Maybe term2 -> Algorithm term1 term2 diff m (Maybe diff)
 diffMaybe (Just a1) (Just a2) = Just <$> diff a1 a2
 diffMaybe (Just a1) _         = Just <$> byDeleting a1
 diffMaybe _         (Just a2) = Just <$> byInserting a2
 diffMaybe _         _         = pure Nothing
 
 -- | Diff two terms linearly.
-linearly :: term1 -> term2 -> Algorithm term1 term2 result result
+linearly :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff
-linearly f1 f2 = Linear f1 f2 `Then` return
+linearly f1 f2 = send (Linear f1 f2 ret)
 
 -- | Diff two terms using RWS.
-byRWS :: [term1] -> [term2] -> Algorithm term1 term2 result [result]
+byRWS :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => [term1] -> [term2] -> Algorithm term1 term2 diff m [diff]
-byRWS as1 as2 = RWS as1 as2 `Then` return
+byRWS as1 as2 = send (RWS as1 as2 ret)
 
 -- | Delete a term.
-byDeleting :: term1 -> Algorithm term1 term2 result result
+byDeleting :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> Algorithm term1 term2 diff m diff
-byDeleting a1 = Delete a1 `Then` return
+byDeleting a1 = sendDiff (Delete a1 ret)
 
 -- | Insert a term.
-byInserting :: term2 -> Algorithm term1 term2 result result
+byInserting :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term2 -> Algorithm term1 term2 diff m diff
-byInserting a2 = Insert a2 `Then` return
+byInserting a2 = sendDiff (Insert a2 ret)
 
 -- | Replace one term with another.
-byReplacing :: term1 -> term2 -> Algorithm term1 term2 result result
+byReplacing :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => term1 -> term2 -> Algorithm term1 term2 diff m diff
-byReplacing a1 a2 = Replace a1 a2 `Then` return
+byReplacing a1 a2 = send (Replace a1 a2 ret)
 
-
+sendDiff :: (Carrier sig m, Member (Diff term1 term2 diff) sig) => Diff term1 term2 diff (Eff m) (Eff m a) -> Algorithm term1 term2 diff m a
-instance (Show term1, Show term2) => Show1 (AlgorithmF term1 term2 result) where
+sendDiff = Algorithm . send
-  liftShowsPrec sp _ d algorithm = case algorithm of
-    Diffing.Algorithm.Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2
-    Linear t1 t2 -> showsBinaryWith showsPrec showsPrec "Linear" d t1 t2
-    RWS as bs -> showsBinaryWith (liftShowsPrec showsPrec showList) (liftShowsPrec showsPrec showList) "RWS" d as bs
-    Delete t1 -> showsUnaryWith showsPrec "Delete" d t1
-    Insert t2 -> showsUnaryWith showsPrec "Insert" d t2
-    Replace t1 t2 -> showsBinaryWith showsPrec showsPrec "Replace" d t1 t2
-    Empty -> showString "Empty"
-    Alt a b -> showsBinaryWith sp sp "Alt" d a b
-
-
-instance Alternative (Algorithm term1 term2 result) where
-  empty = Empty `Then` return
-
-  (Empty `Then` _) <|> a2               = a2
-  a1               <|> (Empty `Then` _) = a1
-  a1               <|> a2               = Alt a1 a2 `Then` id
 
 
 -- | Diff two terms based on their 'Diffable' instances, performing substructural comparisons iff the initial comparison fails.
-algorithmForTerms :: Diffable syntax
+algorithmForTerms :: (Carrier sig m, Diffable syntax, Member (Diff (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2)) sig, Member NonDet sig)
                   => Term syntax ann1
                   -> Term syntax ann2
-                  -> Algorithm (Term syntax ann1) (Term syntax ann2) (Diff syntax ann1 ann2) (Diff syntax ann1 ann2)
+                  -> Algorithm (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2) m (Diff.Diff syntax ann1 ann2)
 algorithmForTerms t1@(Term (In ann1 f1)) t2@(Term (In ann2 f2))
   =   mergeFor t1 t2
-  <|> deleteF . In ann1      <$> subalgorithmFor byDeleting  (`mergeFor` t2) f1
+  <|> Diff.deleteF . In ann1      <$> subalgorithmFor byDeleting  (`mergeFor` t2) f1
-  <|> insertF . In      ann2 <$> subalgorithmFor byInserting (mergeFor t1) f2
+  <|> Diff.insertF . In      ann2 <$> subalgorithmFor byInserting (mergeFor t1) f2
-  where mergeFor (Term (In ann1 f1)) (Term (In ann2 f2)) = merge (ann1, ann2) <$> algorithmFor f1 f2
+  where mergeFor (Term (In ann1 f1)) (Term (In ann2 f2)) = Diff.merge (ann1, ann2) <$> algorithmFor f1 f2
 
 -- | An O(1) relation on terms indicating their non-recursive comparability (i.e. are they of the same “kind” in a way that warrants comparison), defined in terms of the comparability of their respective syntax.
 comparableTerms :: Diffable syntax
@@ -146,14 +142,15 @@ instance Alternative Equivalence where
 -- | A type class for determining what algorithm to use for diffing two terms.
 class Diffable f where
   -- | Construct an algorithm to diff a pair of @f@s populated with disjoint terms.
-  algorithmFor :: f term1
+  algorithmFor :: (Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig)
+               => f term1
                -> f term2
-               -> Algorithm term1 term2 result (f result)
+               -> Algorithm term1 term2 diff m (f diff)
   default
-    algorithmFor :: (Generic1 f, GDiffable (Rep1 f))
+    algorithmFor :: (Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig)
                  => f term1
                  -> f term2
-                 -> Algorithm term1 term2 result (f result)
+                 -> Algorithm term1 term2 diff m (f diff)
   algorithmFor = genericAlgorithmFor
 
   tryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
@@ -170,7 +167,7 @@ class Diffable f where
   --   These two functions allow us to say e.g. that comparisons against 'Data.Syntax.Context' should also be made against its subject, but not against any of the comments, resulting in the insertion of both comments and context when documenting an existing function.
   --
   --   By default, 'subalgorithmFor' produces 'empty', rejecting substructural comparisons. This is important for performance, as alternations with 'empty' are eliminated at construction time.
-  -- ^ The 'Alternative' instance will in general be 'Algorithm', but left opaque to make it harder to shoot oneself in the foot.
+  -- ^ The 'Alternative' instance will in general be 'Diff', but left opaque to make it harder to shoot oneself in the foot.
   subalgorithmFor :: Alternative g
                   => (a -> g b)    -- ^ A “blur” function to traverse positions which should not be diffed against.
                   -> (a -> g b)    -- ^ A “focus” function to traverse positions which should be diffed against.
@@ -193,10 +190,10 @@ class Diffable f where
   default comparableTo :: (Generic1 f, GDiffable (Rep1 f)) => f term1 -> f term2 -> Bool
   comparableTo = genericComparableTo
 
-genericAlgorithmFor :: (Generic1 f, GDiffable (Rep1 f))
+genericAlgorithmFor :: (Carrier sig m, Generic1 f, GDiffable (Rep1 f), Member (Diff term1 term2 diff) sig, Member NonDet sig)
                     => f term1
                     -> f term2
-                    -> Algorithm term1 term2 result (f result)
+                    -> Algorithm term1 term2 diff m (f diff)
 genericAlgorithmFor a1 a2 = to1 <$> galgorithmFor (from1 a1) (from1 a2)
 
 genericComparableTo :: (Generic1 f, GDiffable (Rep1 f)) => f term1 -> f term2 -> Bool
@@ -241,7 +238,7 @@ instance Diffable NonEmpty where
 
 -- | A generic type class for diffing two terms defined by the Generic1 interface.
 class GDiffable f where
-  galgorithmFor :: f term1 -> f term2 -> Algorithm term1 term2 result (f result)
+  galgorithmFor :: (Carrier sig m, Member (Diff term1 term2 diff) sig, Member NonDet sig) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff)
 
   gtryAlignWith :: Alternative g => (These a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
 

src/Diffing/Interpreter.hs

@@ -1,12 +1,15 @@
-{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
+{-# LANGUAGE LambdaCase, TypeOperators, UndecidableInstances #-}
 module Diffing.Interpreter
 ( diffTerms
 , diffTermPair
 , stripDiff
 ) where
 
-import Control.Monad.Free.Freer
+import Control.Effect
-import Data.Diff
+import Control.Effect.Carrier
+import Control.Effect.NonDet
+import Control.Effect.Sum
+import qualified Data.Diff as Diff
 import Data.Term
 import Diffing.Algorithm
 import Diffing.Algorithm.RWS
@@ -16,36 +19,52 @@ import Prologue
 diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax)
           => Term syntax ann
           -> Term syntax ann
-          -> Diff syntax ann ann
+          -> Diff.Diff syntax ann ann
-diffTerms t1 t2 = stripDiff (fromMaybe (replacing t1' t2') (runAlgorithm (diff t1' t2')))
+diffTerms t1 t2 = stripDiff (fromMaybe (Diff.replacing t1' t2') (run (runNonDetOnce (runDiff (algorithmForTerms t1' t2')))))
   where (t1', t2') = ( defaultFeatureVectorDecorator t1
                      , defaultFeatureVectorDecorator t2)
 
 -- | Strips the head annotation off a diff annotated with non-empty records.
 stripDiff :: Functor syntax
-          => Diff syntax (FeatureVector, ann) (FeatureVector, ann)
+          => Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)
-          -> Diff syntax ann ann
+          -> Diff.Diff syntax ann ann
 stripDiff = bimap snd snd
 
 -- | Diff a 'These' of terms.
-diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Diff syntax ann ann
+diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Diff.Diff syntax ann ann
-diffTermPair = these deleting inserting diffTerms
+diffTermPair = these Diff.deleting Diff.inserting diffTerms
 
 
 -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
-runAlgorithm :: (Diffable syntax, Eq1 syntax, Traversable syntax, Alternative m, Monad m)
+runDiff :: (Alternative m, Carrier sig m, Diffable syntax, Eq1 syntax, Member NonDet sig, Monad m, Traversable syntax)
-             => Algorithm
+        => Algorithm
-                  (Term syntax (FeatureVector, ann))
+             (Term syntax (FeatureVector, ann))
-                  (Term syntax (FeatureVector, ann))
+             (Term syntax (FeatureVector, ann))
-                  (Diff syntax (FeatureVector, ann) (FeatureVector, ann))
+             (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann))
-                  result
+             (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m)
-             -> m result
+             result
-runAlgorithm = iterFreerA (\ yield step -> case step of
+        -> m result
-  Diffing.Algorithm.Diff t1 t2 -> runAlgorithm (algorithmForTerms t1 t2) <|> pure (replacing t1 t2) >>= yield
+runDiff = runDiffC . interpret . runAlgorithm
-  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
+
-  Delete a -> yield (deleting a)
+newtype DiffC term1 term2 diff m a = DiffC { runDiffC :: m a }
-  Insert b -> yield (inserting b)
+
-  Replace a b -> yield (replacing a b)
+instance ( Alternative m
-  Empty -> empty
+         , Carrier sig m
-  Alt a b -> yield a <|> yield b)
+         , Diffable syntax
+         , Eq1 syntax
+         , Member NonDet sig
+         , Monad m
+         , Traversable syntax
+         )
+      => Carrier
+        (Diff (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) :+: sig)
+        (DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m) where
+  ret = DiffC . ret
+  eff = DiffC . handleSum (eff . handleCoercible) (\case
+    Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= runDiffC . k
+    Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= runDiffC . k
+    RWS as bs k -> traverse (runDiff . diffThese) (rws comparableTerms equivalentTerms as bs) >>= runDiffC . k
+    Delete a k -> runDiffC (k (Diff.deleting a))
+    Insert b k -> runDiffC (k (Diff.inserting b))
+    Replace a b k -> runDiffC (k (Diff.replacing a b)))

src/Prologue.hs

@@ -12,6 +12,7 @@ import Control.DeepSeq as X
 import Data.Bifunctor.Join as X
 import Data.Bits as X
 import Data.ByteString as X (ByteString)
+import Data.Coerce as X
 import Data.Functor.Both as X (Both, both, runBothWith)
 import Data.IntMap as X (IntMap)
 import Data.IntSet as X (IntSet)

src/Semantic/CLI.hs

@@ -6,6 +6,7 @@ module Semantic.CLI
 , Parse.runParse
 ) where
 
+import           Control.Exception as Exc (displayException)
 import           Data.File
 import           Data.Language (ensureLanguage, languageForFilePath)
 import           Data.List (intercalate, uncons)
@@ -24,12 +25,17 @@ import qualified Semantic.Task as Task
 import           Semantic.Task.Files
 import qualified Semantic.Telemetry.Log as Log
 import           Semantic.Version
+import           System.Exit (die)
 import           System.FilePath
 import           Serializing.Format hiding (Options)
 import           Text.Read
 
 main :: IO ()
-main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
+main = do
+  (options, task) <- customExecParser (prefs showHelpOnEmpty) arguments
+  res <- Task.withOptions options $ \ config logger statter ->
+    Task.runTaskWithConfig config { configSHA = Just buildSHA } logger statter task
+  either (die . displayException) pure res
 
 -- | A parser for the application's command-line arguments.
 --

src/Semantic/Config.hs

@@ -23,7 +23,6 @@ import           Semantic.Env
 import           Semantic.Telemetry
 import qualified Semantic.Telemetry.Haystack as Haystack
 import qualified Semantic.Telemetry.Stat as Stat
-import           Semantic.Version
 import           System.Environment
 import           System.IO (hIsTerminalDevice, stdout)
 import           System.Posix.Process
@@ -44,6 +43,7 @@ data Config
   , configIsTerminal             :: Bool         -- ^ Whether a terminal is attached (set automaticaly at runtime).
   , configLogPrintSource         :: Bool         -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
   , configLogFormatter           :: LogFormatter -- ^ Log formatter to use (set automaticaly at runtime).
+  , configSHA                    :: Maybe String -- ^ Optional SHA to include in log messages.
 
   , configOptions                :: Options      -- ^ Options configurable via command line arguments.
   }
@@ -88,6 +88,7 @@ defaultConfig options@Options{..} = do
     , configIsTerminal = isTerminal
     , configLogPrintSource = isTerminal
     , configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter
+    , configSHA = Nothing
 
     , configOptions = options
     }
@@ -109,8 +110,9 @@ logOptionsFromConfig Config{..} = LogOptions
           False -> [ ("app", configAppName)
                    , ("pid", show configProcessID)
                    , ("hostname", configHostName)
-                   , ("sha", buildSHA)
+                   , ("sha", fromMaybe "development" configSHA)
-                   ] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ]
+                   ]
+                   <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ]
           _ -> []
 
 

src/Semantic/REPL.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, KindSignatures, LambdaCase, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, LambdaCase, TypeOperators, UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-missing-signatures #-}
 module Semantic.REPL
 ( rubyREPL
@@ -8,6 +8,7 @@ import Control.Abstract hiding (Continue, List, string)
 import Control.Effect.Carrier
 import Control.Effect.Resource
 import Control.Effect.Sum
+import Control.Effect.REPL
 import Data.Abstract.Address.Precise as Precise
 import Data.Abstract.Environment as Env
 import Data.Abstract.Evaluatable hiding (string)
@@ -16,7 +17,6 @@ import Data.Abstract.ModuleTable as ModuleTable
 import Data.Abstract.Package
 import Data.Abstract.Value.Concrete as Concrete
 import Data.Blob (Blob(..))
-import Data.Coerce
 import Data.Error (showExcerpt)
 import Data.File (File (..), readBlobFromFile)
 import Data.Graph (topologicalSort)
@@ -25,6 +25,7 @@ import Data.List (uncons)
 import Data.Project
 import Data.Quieterm
 import Data.Span
+import qualified Data.Text as T
 import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
 import qualified Data.Time.LocalTime as LocalTime
 import Numeric (readDec)
@@ -45,43 +46,11 @@ import System.Console.Haskeline
 import System.Directory (createDirectoryIfMissing, getHomeDirectory)
 import System.FilePath
 
-data REPL (m :: * -> *) k
-  = Prompt (Maybe String -> k)
-  | Output String k
-  deriving (Functor)
-
-prompt :: (Member REPL sig, Carrier sig m) => m (Maybe String)
-prompt = send (Prompt ret)
-
-output :: (Member REPL sig, Carrier sig m) => String -> m ()
-output s = send (Output s (ret ()))
-
-
 data Quit = Quit
   deriving Show
 
 instance Exception Quit
 
-
-instance HFunctor REPL where
-  hmap _ = coerce
-
-instance Effect REPL where
-  handle state handler (Prompt k) = Prompt (handler . (<$ state) . k)
-  handle state handler (Output s k) = Output s (handler (k <$ state))
-
-
-runREPL :: (MonadIO m, Carrier sig m) => Prefs -> Settings IO -> Eff (REPLC m) a -> m a
-runREPL prefs settings = flip runREPLC (prefs, settings) . interpret
-
-newtype REPLC m a = REPLC { runREPLC :: (Prefs, Settings IO) -> m a }
-
-instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
-  ret = REPLC . const . ret
-  eff op = REPLC (\ args -> handleSum (eff . handleReader args runREPLC) (\case
-    Prompt   k -> liftIO (uncurry runInputTWithPrefs args (getInputLine (cyan <> "repl: " <> plain))) >>= flip runREPLC args . k
-    Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn s)) *> runREPLC k args) op)
-
 rubyREPL = repl (Proxy @'Language.Ruby) rubyParser
 
 repl proxy parser paths = defaultConfig debugOptions >>= \ config -> runM . runDistribute . runResource (runM . runDistribute) . runTimeout (runM . runDistribute . runResource (runM . runDistribute)) . runError @_ @_ @SomeException . runTelemetryIgnoringStat (logOptionsFromConfig config) . runTraceInTelemetry . runReader config . Files.runFiles . runResolution . runTaskF $ do
@@ -162,7 +131,7 @@ step blobs recur0 recur term = do
   where list = do
           path <- asks modulePath
           span <- ask
-          maybe (pure ()) (\ blob -> output (showExcerpt True span blob "")) (Prelude.lookup path blobs)
+          maybe (pure ()) (\ blob -> output (T.pack (showExcerpt True span blob ""))) (Prelude.lookup path blobs)
         help = do
           output "Commands available from the prompt:"
           output ""
@@ -174,12 +143,12 @@ step blobs recur0 recur term = do
           output "  :quit, :q, :abandon         abandon the current evaluation and exit the repl"
         showBindings = do
           bindings <- Env.head <$> getEnv
-          output $ unlines (uncurry showBinding <$> Env.pairs bindings)
+          output . T.pack $ unlines (uncurry showBinding <$> Env.pairs bindings)
         showBinding name addr = show name <> " = " <> show addr
         runCommand run [":step"]     = local (const Step) run
         runCommand run [":continue"] = local (const Continue) run
         runCommand run [":break", s]
-          | [(i, "")] <- readDec s = modify (OnLine i :) >> runCommands run
+          | [(i, "")] <- readDec (T.unpack s) = modify (OnLine i :) >> runCommands run
         -- TODO: :show breakpoints
         -- TODO: :delete breakpoints
         runCommand run [":list"] = list >> runCommands run
@@ -190,10 +159,10 @@ step blobs recur0 recur term = do
         runCommand run [":help"] = help >> runCommands run
         runCommand run [":?"] = help >> runCommands run
         runCommand run [] = runCommands run
-        runCommand run other = output ("unknown command '" <> unwords other <> "'") >> output "use :? for help" >> runCommands run
+        runCommand run other = output ("unknown command '" <> T.unwords other <> "'") >> output "use :? for help" >> runCommands run
         runCommands run = do
-          str <- prompt
+          str <- prompt "repl: "
-          maybe (runCommands run) (runCommand run . words) str
+          maybe (runCommands run) (runCommand run . T.words) str
 
 
 newtype Breakpoint
@@ -224,10 +193,3 @@ shouldBreak = do
           | n >= posLine spanStart
           , n <= posLine spanEnd   = True
           | otherwise              = False
-
-
-cyan :: String
-cyan = "\ESC[1;36m\STX"
-
-plain :: String
-plain = "\ESC[0m\STX"

test/Control/Abstract/Evaluator/Spec.hs

@@ -14,7 +14,6 @@ import Data.Abstract.Package
 import Data.Abstract.Value.Concrete as Value
 import Data.Algebra
 import Data.Bifunctor (first)
-import Data.Coerce
 import Data.Functor.Const
 import Data.Sum
 import SpecHelpers hiding (reassociate)

test/Data/Abstract/Environment/Spec.hs

@@ -0,0 +1,21 @@
+module Data.Abstract.Environment.Spec where
+
+import Prelude hiding (head)
+import SpecHelpers
+
+import Data.Abstract.Environment
+import Data.Abstract.Address.Precise
+
+spec :: Spec
+spec = describe "Environment" $ do
+  let bright = push (insertEnv (name "foo") (Precise 0) lowerBound)
+  let shadowed = insertEnv (name "foo") (Precise 1) bright
+
+  it "can extract bindings" $
+    pairs (head shadowed) `shouldBe` [("foo", Precise 1)]
+
+  it "should extract the outermost binding given shadowing" $
+    lookupEnv' (name "foo") shadowed `shouldBe` Just (Precise 1)
+
+  it "can delete bindings" $
+    delete (name "foo") shadowed `shouldBe` Environment (pure lowerBound)

test/Data/Abstract/Name/Spec.hs

@@ -0,0 +1,11 @@
+module Data.Abstract.Name.Spec where
+
+import SpecHelpers
+
+import Data.Abstract.Name
+
+spec :: Spec
+spec = describe "Data.Abstract.Name" $
+  it "should format anonymous names correctly" $ do
+    show (nameI 0)  `shouldBe` "\"_a\""
+    show (nameI 26) `shouldBe` "\"_aʹ\""

test/Data/Functor/Listable.hs

@@ -31,6 +31,7 @@ import Data.Patch
 import Data.Range
 import Data.Location
 import Data.Semigroup (Semigroup(..))
+import Data.Semigroup.App
 import Data.Source
 import Data.Blob
 import Data.Span
@@ -527,6 +528,12 @@ instance Listable Language.Language where
     \/ cons0 Language.Ruby
     \/ cons0 Language.TypeScript
 
+instance Listable (f a) => Listable (App f a) where
+  tiers = cons1 App
+
+instance Listable (f a) => Listable (AppMerge f a) where
+  tiers = cons1 AppMerge
+
 instance Listable Location where
   tiers = cons2 Location
 

test/Data/Graph/Spec.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE PackageImports #-}
+
+module Data.Graph.Spec where
+
+import SpecHelpers
+
+import "semantic" Data.Graph
+import qualified Algebra.Graph.Class as Class
+
+spec :: Spec
+spec = describe "Data.Graph" $
+  it "has a valid topological sort" $ do
+    let topo = topologicalSort
+    topo (Class.path "ab") `shouldBe` "ba"
+    topo (Class.path "abc") `shouldBe` "cba"
+    topo ((vertex 'a' `connect` vertex 'b') `connect` vertex 'c') `shouldBe` "cba"
+    topo (vertex 'a' `connect` (vertex 'b' `connect` vertex 'c')) `shouldBe` "cba"
+    topo ((vertex 'a' `connect` vertex 'b') <> (vertex 'a' `connect` vertex 'c')) `shouldBe` "cba"
+    topo (Class.path "abd" <> Class.path "acd") `shouldBe` "dcba"
+    topo (Class.path "aba") `shouldBe` "ab"

test/Data/Range/Spec.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Data.Range.Spec where
+
+import Data.Range
+import SpecHelpers
+
+spec :: Spec
+spec = describe "Data.Range" $
+  prop "should have an associative Semigroup instance" $
+    \(a, b, c) -> a <> (b <> c) `shouldBe` (a <> b) <> (c :: Range)

test/Data/Semigroup/App/Spec.hs

@@ -0,0 +1,20 @@
+module Data.Semigroup.App.Spec where
+
+import SpecHelpers
+import Data.Semigroup.App
+
+spec :: Spec
+spec = do
+  describe "App" $
+    prop "should be associative" $
+      \a b c -> a <> (b <> c) == (a <> b) <> (c :: App Maybe Integer)
+
+  describe "AppMerge" $ do
+    prop "should be associative" $
+      \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String)
+
+    prop "identity/left" $
+      \ a -> mempty <> a == (a :: AppMerge Maybe String)
+
+    prop "identity/right" $
+      \ a -> a <> mempty == (a :: AppMerge Maybe String)

test/Doctests.hs

@@ -1,37 +0,0 @@
-module Main
-( main
-) where
-
-import System.Environment
-import Test.DocTest
-
-defaultFiles =
-  [ "src/Data/Abstract/Address/Precise.hs"
-  , "src/Data/Abstract/Environment.hs"
-  , "src/Data/Abstract/Name.hs"
-  , "src/Data/Graph.hs"
-  , "src/Data/Range.hs"
-  , "src/Data/Semigroup/App.hs"
-  ]
-
-main :: IO ()
-main = do
-  args <- getArgs
-  doctest (map ("-X" ++) extensions ++ "-isrc" : "--fast" : if null args then defaultFiles else args)
-
-extensions :: [String]
-extensions =
-  [ "DataKinds"
-  , "DeriveFoldable"
-  , "DeriveFunctor"
-  , "DeriveGeneric"
-  , "DeriveTraversable"
-  , "FlexibleContexts"
-  , "FlexibleInstances"
-  , "MultiParamTypeClasses"
-  , "OverloadedStrings"
-  , "RecordWildCards"
-  , "StandaloneDeriving"
-  , "StrictData"
-  , "TypeApplications"
-  ]

test/Graphing/Calls/Spec.hs

@@ -18,7 +18,7 @@ import           Semantic.Config (defaultOptions)
 import           Semantic.Graph
 import           Semantic.IO
 
-callGraphPythonProject paths = runTaskWithOptions defaultOptions $ do
+callGraphPythonProject paths = runTask $ do
   let proxy = Proxy @'Language.Python
   let lang = Language.Python
   blobs <- catMaybes <$> traverse readBlobFromFile (flip File lang <$> paths)

test/Rendering/TOC/Spec.hs

@@ -17,7 +17,7 @@ import Data.Sum
 import Data.Term
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
-import Diffing.Algorithm
+import Diffing.Algorithm hiding (Diff)
 import Diffing.Interpreter
 import Prelude
 import qualified Data.Syntax as Syntax

test/Spec.hs

@@ -9,9 +9,14 @@ import qualified Assigning.Assignment.Spec
 import qualified Control.Abstract.Evaluator.Spec
 import qualified Control.Rewriting.Spec
 import qualified Data.Diff.Spec
+import qualified Data.Abstract.Environment.Spec
+import qualified Data.Abstract.Name.Spec
 import qualified Data.Abstract.Path.Spec
 import qualified Data.Functor.Classes.Generic.Spec
+import qualified Data.Graph.Spec
+import qualified Data.Range.Spec
 import qualified Data.Scientific.Spec
+import qualified Data.Semigroup.App.Spec
 import qualified Data.Source.Spec
 import qualified Data.Term.Spec
 import qualified Diffing.Algorithm.RWS.Spec
@@ -48,9 +53,14 @@ main = do
       describe "Control.Abstract.Evaluator" Control.Abstract.Evaluator.Spec.spec
       describe "Control.Rewriting.Spec" Control.Rewriting.Spec.spec
       describe "Data.Diff" Data.Diff.Spec.spec
+      describe "Data.Graph" Data.Graph.Spec.spec
+      describe "Data.Abstract.Environment.Spec" Data.Abstract.Environment.Spec.spec
       describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
+      describe "Data.Abstract.Name" Data.Abstract.Name.Spec.spec
       describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
+      describe "Data.Range" Data.Range.Spec.spec
       describe "Data.Scientific" Data.Scientific.Spec.spec
+      describe "Data.Semigroup.App" Data.Semigroup.App.Spec.spec
       describe "Data.Source" Data.Source.Spec.spec
       describe "Data.Term" Data.Term.Spec.spec
       describe "Diffing.Algorithm.RWS" Diffing.Algorithm.RWS.Spec.spec

vendor/fused-effects

@@ -1 +1 @@
-Subproject commit 5f11d009d486b4e7e1741d0d031f8818818856ea
+Subproject commit 7421ffa4e2d05b961fb0347ddab5ebdef9e32f25