Merge remote-tracking branch 'origin/master' into repo-import-graph

semantic.cabal

@@ -82,6 +82,7 @@ library
                      , Data.Range
                      , Data.Record
                      , Data.Semigroup.App
+                     , Data.Scientific.Exts
                      , Data.Source
                      , Data.Span
                      , Data.SplitDiff
@@ -136,13 +137,16 @@ library
                      , Rendering.Symbol
                      , Rendering.TOC
                      -- High-level flow & operational functionality (logging, stats, etc.)
-                     , Semantic
                      , Semantic.CLI
+                     , Semantic.Diff
+                     , Semantic.Distribute
                      , Semantic.IO
                      , Semantic.Log
+                     , Semantic.Parse
+                     , Semantic.Queue
                      , Semantic.Stat
                      , Semantic.Task
-                     , Semantic.Queue
+                     , Semantic.Telemetry
                      , Semantic.Util
                     -- Custom Prelude
   other-modules:       Prologue
@@ -152,6 +156,7 @@ library
                      , ansi-terminal
                      , array
                      , async
+                     , attoparsec
                      , bifunctors
                      , bytestring
                      , cmark-gfm
@@ -234,6 +239,7 @@ test-suite test
                      , Data.Functor.Classes.Generic.Spec
                      , Data.Functor.Listable
                      , Data.Mergeable.Spec
+                     , Data.Scientific.Spec
                      , Data.Source.Spec
                      , Data.Term.Spec
                      , Diffing.Algorithm.RWS.Spec

src/Analysis/Abstract/Evaluating.hs

@@ -152,7 +152,6 @@ instance Members (EvaluatingEffects location term value) effects
 
 instance ( Corecursive term
          , Members (EvaluatingEffects location term value) effects
-         , MonadValue location value (Evaluating location term value effects)
          , Recursive term
          )
       => MonadAnalysis location term value (Evaluating location term value effects) where

src/Control/Abstract/Analysis.hs

@@ -1,9 +1,11 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies #-}
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis
 module Control.Abstract.Analysis
 ( MonadAnalysis(..)
 , liftAnalyze
 , runAnalysis
+, SomeAnalysis(..)
+, runSomeAnalysis
 , module X
 , Subterm(..)
 , SubtermAlgebra
@@ -62,3 +64,18 @@ runAnalysis :: ( Effectful m
             => m effects a
             -> Final effects a
 runAnalysis = X.run
+
+
+-- | An abstraction over analyses.
+data SomeAnalysis m result where
+  SomeAnalysis :: ( Effectful m
+                  , effects ~ Effects location term value (m effects)
+                  , MonadAnalysis location term value (m effects)
+                  , RunEffects effects a
+                  )
+               => m effects a
+               -> SomeAnalysis m (Final effects a)
+
+-- | Run an abstracted analysis.
+runSomeAnalysis :: SomeAnalysis m result -> result
+runSomeAnalysis (SomeAnalysis a) = X.run a

src/Data/Abstract/Environment.hs

@@ -27,8 +27,8 @@ import           GHC.Exts (IsList (..))
 import           Prologue
 
 -- $setup
--- >>> let bright = push (insert "foo" (Address (Precise 0)) mempty)
--- >>> let shadowed = insert "foo" (Address (Precise 1)) bright
+-- >>> let bright = push (insert (name "foo") (Address (Precise 0)) mempty)
+-- >>> let shadowed = insert (name "foo") (Address (Precise 1)) bright
 
 -- | 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
@@ -85,13 +85,13 @@ mergeNewer (Environment (a :| as)) (Environment (b :| bs)) =
 -- | Extract an association list of bindings from an 'Environment'.
 --
 -- >>> pairs shadowed
--- [("foo",Address {unAddress = Precise {unPrecise = 1}})]
+-- [(Name {unName = "foo"},Address {unAddress = Precise {unPrecise = 1}})]
 pairs :: Environment l a -> [(Name, Address l a)]
 pairs = Map.toList . fold . unEnvironment
 
 -- | Lookup a 'Name' in the environment.
 --
--- >>> lookup "foo" shadowed
+-- >>> lookup (name "foo") shadowed
 -- Just (Address {unAddress = Precise {unPrecise = 1}})
 lookup :: Name -> Environment l a -> Maybe (Address l a)
 lookup k = foldMapA (Map.lookup k) . unEnvironment
@@ -102,7 +102,7 @@ insert name value (Environment (a :| as)) = Environment (Map.insert name value a
 
 -- | Remove a 'Name' from the environment.
 --
--- >>> delete "foo" shadowed
+-- >>> delete (name "foo") shadowed
 -- Environment {unEnvironment = fromList [] :| []}
 delete :: Name -> Environment l a -> Environment l a
 delete name = trim . Environment . fmap (Map.delete name) . unEnvironment

src/Data/Scientific/Exts.hs

@@ -0,0 +1,99 @@
+module Data.Scientific.Exts
+    ( module Data.Scientific
+    , parseScientific
+    ) where
+
+import Prelude hiding (filter, null, takeWhile)
+
+import Control.Applicative
+import Control.Monad
+import Data.Attoparsec.ByteString.Char8
+import Data.ByteString.Char8 hiding (readInt, takeWhile)
+import Data.Char (isOctDigit)
+import Data.Scientific
+import Data.Semigroup
+import Numeric
+import Text.Read (readMaybe)
+
+parseScientific :: ByteString -> Either String Scientific
+parseScientific = parseOnly parser
+
+-- | This is a very flexible and forgiving parser for Scientific values.
+-- Unlike 'scientificP' or Scientific's 'Read' instance, this handles the myriad
+-- array of floating-point syntaxes across languages:
+-- * omitted whole parts, e.g. @.5@
+-- * omitted decimal parts, e.g. @5.@
+-- * numbers with trailing imaginary/length specifiers, @1.7j, 20L@
+-- * numeric parts, in whole or decimal or exponent parts, with @_@ characters
+-- * hexadecimal, octal, and binary literals (TypeScript needs this because all numbers are floats)
+-- You may either omit the whole or the leading part, not both; this parser also rejects the empty string.
+-- It does /not/ handle hexadecimal floating-point numbers yet, as no language we parse supports them.
+-- This will need to be changed when we support Java.
+-- Please note there are extant parser bugs where complex literals (e.g. @123j@) are parsed
+-- as floating-point rather than complex quantities. This parser discards all suffixes.
+-- This parser is unit-tested in Data.Scientific.Spec.
+
+parser :: Parser Scientific
+parser = signed (choice [hex, oct, bin, dec]) where
+  -- The ending stanza. Note the explicit endOfInput call to ensure we haven't left any dangling input.
+  done = skipWhile (inClass "iIjJlL") *> endOfInput
+
+  -- Wrapper around readMaybe. Analogous to maybeFail in the Prologue, but no need to pull that in.
+  attempt :: Read a => String -> Parser a
+  attempt str = maybe (fail ("No parse: " <> str)) pure (readMaybe str)
+
+  -- Parse a hex value, leaning on the parser provided by Attoparsec.
+  hex = fromIntegral <$> (string "0x" *> hexadecimal @Integer)
+
+  -- We lean on Haskell's octal integer support, parsing
+  -- the given string as an integer then coercing it to a Scientific.
+  oct = do
+    void (char '0' <* optional (char 'o'))
+    digs <- takeWhile1 isOctDigit <* done
+    fromIntegral <$> attempt @Integer (unpack ("0o" <> digs))
+
+  -- The case for binary literals is somewhat baroque. Despite having binary literal support, Integer's
+  -- Read instance does not handle binary literals. So we have to shell out to Numeric.readInt, which
+  -- is a very strange API, but works for our use case. The use of 'error' looks partial, but if Attoparsec
+  -- and readInt do their jobs, it should never happen.
+  bin = do
+    void (string "0b")
+    let isBin = inClass "01"
+    digs <- unpack <$> (takeWhile1 isBin <* done)
+    let c2b c = case c of
+          '0' -> 0
+          '1' -> 1
+          x   -> error ("Invariant violated: both Attoparsec and readInt let a bad digit through: " <> [x])
+    let res = readInt 2 isBin c2b digs
+    case res of
+      []        -> fail ("No parse of binary literal: " <> digs)
+      [(x, "")] -> pure x
+      others    -> fail ("Too many parses of binary literal: " <> show others)
+
+  -- Compared to the binary parser, this is positively breezy.
+  dec = do
+    let notUnder = filter (/= '_')
+    let decOrUnder c = isDigit c || (c == '_')
+
+    -- Try getting the whole part of a floating literal.
+    leadings <- notUnder <$> takeWhile decOrUnder
+
+    -- Try reading a dot.
+    void (optional (char '.'))
+
+    -- The trailing part...
+    trailings <- notUnder <$> takeWhile decOrUnder
+
+    -- ...and the exponent.
+    exponent  <- notUnder <$> takeWhile (inClass "eE_0123456789+-")
+
+    done
+
+    -- Ensure we don't read an empty string, or one consisting only of a dot and/or an exponent.
+    when (null trailings && null leadings) (fail "Does not accept a single dot")
+
+    -- Replace empty parts with a zero.
+    let leads = if null leadings then "0" else leadings
+    let trail = if null trailings then "0" else trailings
+
+    attempt (unpack (leads <> "." <> trail <> exponent))

src/Data/Syntax/Literal.hs

@@ -5,8 +5,7 @@ import Control.Arrow ((>>>))
 import Data.Abstract.Evaluatable
 import Data.ByteString.Char8 (readInteger, unpack)
 import qualified Data.ByteString.Char8 as B
-import Data.Monoid (Endo (..), appEndo)
-import Data.Scientific (Scientific)
+import Data.Scientific.Exts
 import Diffing.Algorithm
 import Prelude hiding (Float, fail, null)
 import Prologue hiding (Set, hash, null)
@@ -58,45 +57,11 @@ instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
 instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec
 
--- | Ensures that numbers of the form '.52' are parsed correctly. Most languages need this.
-padWithLeadingZero :: ByteString -> ByteString
-padWithLeadingZero b
-  | fmap fst (B.uncons b) == Just '.' = B.cons '0' b
-  | otherwise                         = b
-
--- | As @padWithLeadingZero@, but on the end. Not all languages need this.
-padWithTrailingZero :: ByteString -> ByteString
-padWithTrailingZero b
-  | fmap snd (B.unsnoc b) == Just '.' = B.snoc b '0'
-  | otherwise                         = b
-
--- | Removes underscores in numeric literals. Python 3 and Ruby support this, whereas Python 2, JS, and Go do not.
-removeUnderscores :: ByteString -> ByteString
-removeUnderscores = B.filter (/= '_')
-
--- | Strip suffixes from floating-point literals so as to handle Python's
---   TODO: tree-sitter-python needs some love so that it parses j-suffixed floats as complexen
-dropAlphaSuffix :: ByteString -> ByteString
-dropAlphaSuffix = B.takeWhile (\x -> x `notElem` ("lLjJiI" :: Prelude.String))
-
--- | This is the shared function that munges a bytestring representation of a float
---   so that it can be parsed to a @Scientific@ later. It takes as its arguments a list of functions, which
---   will be some combination of the above 'ByteString -> ByteString' functions. This is meant
---   to be called from an @Assignment@, hence the @MonadFail@ constraint. Caveat: the list is
---   order-dependent; the rightmost function will be applied first.
-normalizeFloatString :: MonadFail m => [ByteString -> ByteString] -> ByteString -> m (Float a)
-normalizeFloatString preds val =
-  let munger = appEndo (foldMap Endo preds)
-  in case readMaybe @Scientific (unpack (munger val)) of
-    Nothing -> fail ("Invalid floating-point value: " <> show val)
-    Just _  -> pure (Float val)
-
 instance Evaluatable Data.Syntax.Literal.Float where
-  eval (Float s) = do
-    sci <- case readMaybe (unpack s) of
-      Just s  -> pure s
-      Nothing -> fail ("Bug: non-normalized float string: " <> show s)
-    float sci
+  eval (Float s) =
+    case parseScientific s of
+      Right num -> float num
+      Left  err -> fail ("Parse error: " <> err)
 
 -- Rational literals e.g. `2/3r`
 newtype Rational a = Rational ByteString

src/Language/Go/Assignment.hs

@@ -227,7 +227,7 @@ fieldIdentifier :: Assignment
 fieldIdentifier = makeTerm <$> symbol FieldIdentifier <*> (Syntax.Identifier . name <$> source)
 
 floatLiteral :: Assignment
-floatLiteral = makeTerm <$> symbol FloatLiteral <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero, Literal.dropAlphaSuffix])
+floatLiteral = makeTerm <$> symbol FloatLiteral <*> (Literal.Float <$> source)
 
 identifier :: Assignment
 identifier =  makeTerm <$> (symbol Identifier <|> symbol Identifier') <*> (Syntax.Identifier . name <$> source)

src/Language/JSON/Assignment.hs

@@ -50,7 +50,7 @@ array :: Assignment
 array = makeTerm <$> symbol Array <*> children (Literal.Array <$> many jsonValue)
 
 number :: Assignment
-number = makeTerm <$> symbol Number <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero])
+number = makeTerm <$> symbol Number <*> (Literal.Float <$> source)
 
 string :: Assignment
 string = makeTerm <$> symbol String <*> (Literal.TextElement <$> source)

src/Language/PHP/Assignment.hs

@@ -484,7 +484,7 @@ literal :: Assignment
 literal = integer <|> float <|> string
 
 float :: Assignment
-float = makeTerm <$> symbol Float <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero])
+float = makeTerm <$> symbol Float <*> (Literal.Float <$> source)
 
 integer :: Assignment
 integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source)

src/Language/Python/Assignment.hs

@@ -361,11 +361,7 @@ concatenatedString :: Assignment
 concatenatedString = makeTerm <$> symbol ConcatenatedString <*> children (manyTerm string)
 
 float :: Assignment
-float = makeTerm <$> symbol Float <*> (source >>= Literal.normalizeFloatString [ Literal.padWithLeadingZero
-                                                                               , Literal.padWithTrailingZero
-                                                                               , Literal.dropAlphaSuffix
-                                                                               , Literal.removeUnderscores
-                                                                               ])
+float = makeTerm <$> symbol Float <*> (Literal.Float <$> source)
 
 integer :: Assignment
 integer = makeTerm <$> symbol Integer <*> (Literal.Integer <$> source)

src/Language/Ruby/Assignment.hs

@@ -73,10 +73,11 @@ type Syntax = '[
   , Syntax.Error
   , Syntax.Identifier
   , Syntax.Program
-  , Ruby.Syntax.Require
-  , Ruby.Syntax.Load
   , Ruby.Syntax.Class
+  , Ruby.Syntax.Load
+  , Ruby.Syntax.LowPrecedenceBoolean
   , Ruby.Syntax.Module
+  , Ruby.Syntax.Require
   , []
   ]
 
@@ -157,7 +158,6 @@ identifier =
   <|> mk SplatArgument
   <|> mk HashSplatArgument
   <|> mk BlockArgument
-  <|> mk ReservedIdentifier
   <|> mk Uninterpreted
   where mk s = makeTerm <$> symbol s <*> (Syntax.Identifier . name <$> source)
 
@@ -168,7 +168,7 @@ literal =
   <|> makeTerm <$> token  Grammar.False    <*> pure Literal.false
   <|> makeTerm <$> token  Grammar.Nil      <*> pure Literal.Null
   <|> makeTerm <$> symbol Grammar.Integer  <*> (Literal.Integer <$> source)
-  <|> makeTerm <$> symbol Grammar.Float    <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero, Literal.removeUnderscores])
+  <|> makeTerm <$> symbol Grammar.Float    <*> (Literal.Float <$> source)
   <|> makeTerm <$> symbol Grammar.Rational <*> (Literal.Rational <$> source)
   <|> makeTerm <$> symbol Grammar.Complex  <*> (Literal.Complex <$> source)
    -- TODO: Do we want to represent the difference between .. and ...
@@ -369,9 +369,11 @@ binary = makeTerm' <$> symbol Binary <*> children (infixTerm expression expressi
   , (inj .) . Expression.Power            <$ symbol AnonStarStar
   , (inj .) . Expression.DividedBy        <$ symbol AnonSlash
   , (inj .) . Expression.Modulo           <$ symbol AnonPercent
-  , (inj .) . Expression.And              <$ (symbol AnonAnd <|> symbol AnonAmpersandAmpersand)
+  , (inj .) . Expression.And              <$ symbol AnonAmpersandAmpersand
+  , (inj .) . Ruby.Syntax.LowAnd          <$ symbol AnonAnd
   , (inj .) . Expression.BAnd             <$ symbol AnonAmpersand
-  , (inj .) . Expression.Or               <$ (symbol AnonOr <|> symbol AnonPipePipe)
+  , (inj .) . Expression.Or               <$ symbol AnonPipePipe
+  , (inj .) . Ruby.Syntax.LowOr           <$ symbol AnonOr
   , (inj .) . Expression.BOr              <$ symbol AnonPipe
   , (inj .) . Expression.BXOr             <$ symbol AnonCaret
   , (inj .) . Expression.Equal            <$ (symbol AnonEqualEqual <|> symbol AnonEqualEqualEqual)

src/Language/Ruby/Syntax.hs

@@ -116,3 +116,22 @@ instance Evaluatable Module where
     name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
     letrec' name $ \addr ->
       eval xs <* makeNamespace name addr []
+
+data LowPrecedenceBoolean a
+  = LowAnd !a !a
+  | LowOr !a !a
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
+
+instance Evaluatable LowPrecedenceBoolean where
+  -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
+  eval = go . fmap subtermValue where
+    go (LowAnd a b) = do
+      cond <- a
+      ifthenelse cond b (pure cond)
+    go (LowOr a b) = do
+      cond <- a
+      ifthenelse cond (pure cond) b
+
+instance Eq1 LowPrecedenceBoolean where liftEq = genericLiftEq
+instance Ord1 LowPrecedenceBoolean where liftCompare = genericLiftCompare
+instance Show1 LowPrecedenceBoolean where liftShowsPrec = genericLiftShowsPrec

src/Language/TypeScript/Assignment.hs

@@ -325,7 +325,7 @@ importAlias' :: Assignment
 importAlias' = makeTerm <$> symbol Grammar.ImportAlias <*> children (TypeScript.Syntax.ImportAlias <$> term identifier <*> term (identifier <|> nestedIdentifier))
 
 number :: Assignment
-number = makeTerm <$> symbol Grammar.Number <*> (source >>= Literal.normalizeFloatString [Literal.padWithLeadingZero])
+number = makeTerm <$> symbol Grammar.Number <*> (Literal.Float <$> source)
 
 string :: Assignment
 string = makeTerm <$> symbol Grammar.String <*> (Literal.TextElement <$> source)

src/Semantic.hs

@@ -1,94 +0,0 @@
-{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveDataTypeable, GADTs, TypeOperators #-}
-module Semantic
-( parseBlobs
-, parseBlob
-, diffBlobPairs
-, diffBlobPair
-, diffTermPair
-) where
-
-import Prologue
-import Analysis.ConstructorName (ConstructorName, constructorLabel)
-import Analysis.IdentifierName (IdentifierName, identifierLabel)
-import Analysis.Declaration (HasDeclaration, declarationAlgebra)
-import Analysis.PackageDef (HasPackageDef, packageDefAlgebra)
-import Data.Blob
-import Data.Diff
-import Data.JSON.Fields
-import Data.Output
-import Data.Record
-import Data.Term
-import Diffing.Algorithm (Diffable)
-import Diffing.Interpreter
-import Parsing.Parser
-import Rendering.Renderer
-import Semantic.Stat as Stat
-import Semantic.Task as Task
-
--- This is the primary interface to the Semantic library which provides two
--- major classes of functionality: semantic parsing and diffing of source code
--- blobs.
---
--- Design goals:
---   - No knowledge of the filesystem or Git.
---   - Built in concurrency where appropriate.
---   - Easy to consume this interface from other application (e.g a cmdline or web server app).
-
-parseBlobs :: Output output => TermRenderer output -> [Blob] -> Task ByteString
-parseBlobs renderer blobs = toOutput' <$> distributeFoldMap (parseBlob renderer) blobs
-  where toOutput' = case renderer of
-          JSONTermRenderer -> toOutput . renderJSONTerms
-          SymbolsTermRenderer _ -> toOutput . renderSymbolTerms
-          _ -> toOutput
-
--- | A task to parse a 'Blob' and render the resulting 'Term'.
-parseBlob :: TermRenderer output -> Blob -> Task output
-parseBlob renderer blob@Blob{..}
-  | Just (SomeParser parser) <- someParser (Proxy :: Proxy '[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1]) <$> blobLanguage
-  = parse parser blob >>= case renderer of
-    JSONTermRenderer           -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)
-    SExpressionTermRenderer    -> decorate constructorLabel . (Nil <$)                   >=> render renderSExpressionTerm
-    TagsTermRenderer           -> decorate (declarationAlgebra blob)                     >=> render (renderToTags blob)
-    ImportsTermRenderer        -> decorate (declarationAlgebra blob) >=> decorate (packageDefAlgebra blob) >=> render (renderToImports blob)
-    SymbolsTermRenderer fields -> decorate (declarationAlgebra blob)                     >=> render (renderToSymbols fields blob)
-    DOTTermRenderer            ->                                                            render (renderDOTTerm blob)
-  | otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
-
-newtype NoLanguageForBlob = NoLanguageForBlob FilePath
-  deriving (Eq, Exception, Ord, Show, Typeable)
-
-
-diffBlobPairs :: Output output => DiffRenderer output -> [BlobPair] -> Task ByteString
-diffBlobPairs renderer blobs = toOutput' <$> distributeFoldMap (diffBlobPair renderer) blobs
-  where toOutput' = case renderer of
-          JSONDiffRenderer -> toOutput . renderJSONDiffs
-          _ -> toOutput
-
--- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'.
-diffBlobPair :: DiffRenderer output -> BlobPair -> Task output
-diffBlobPair renderer blobs
-  | Just (SomeParser parser) <- someParser (Proxy :: Proxy '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable]) <$> effectiveLanguage
-  = case renderer of
-    ToCDiffRenderer         -> run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob))                     diffTerms renderToCDiff
-    JSONDiffRenderer        -> run (          parse parser      >=> decorate constructorLabel >=> decorate identifierLabel) diffTerms renderJSONDiff
-    SExpressionDiffRenderer -> run (          parse parser      >=> decorate constructorLabel . (Nil <$))                   diffTerms (const renderSExpressionDiff)
-    DOTDiffRenderer         -> run (          parse parser)                                                                 diffTerms renderDOTDiff
-  | otherwise = throwError (SomeException (NoLanguageForBlob effectivePath))
-  where effectivePath = pathForBlobPair blobs
-        effectiveLanguage = languageForBlobPair blobs
-
-        run :: (Foldable syntax, Functor syntax) => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (BlobPair -> Diff syntax ann ann -> output) -> Task output
-        run parse diff renderer = do
-          terms <- bidistributeFor (runJoin blobs) parse parse
-          time "diff" languageTag $ do
-            diff <- diffTermPair diff terms
-            writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
-            render (renderer blobs) diff
-          where
-            languageTag = languageTagForBlobPair blobs
-
--- | A task to diff 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's.
-diffTermPair :: Functor syntax => Differ syntax ann1 ann2 -> These (Term syntax ann1) (Term syntax ann2) -> Task (Diff syntax ann1 ann2)
-diffTermPair _      (This  t1   ) = pure (deleting t1)
-diffTermPair _      (That     t2) = pure (inserting t2)
-diffTermPair differ (These t1 t2) = diff differ t1 t2

src/Semantic/CLI.hs

@@ -16,26 +16,27 @@ import Options.Applicative
 import Rendering.Renderer
 import qualified Paths_semantic as Library (version)
 import Semantic.IO (languageForFilePath)
+import qualified Semantic.Diff as Semantic (diffBlobPairs)
 import qualified Semantic.Log as Log
+import qualified Semantic.Parse as Semantic (parseBlobs)
 import qualified Semantic.Task as Task
 import System.IO (Handle, stdin, stdout)
-import qualified Semantic (parseBlobs, diffBlobPairs)
 import Text.Read
 
 
 main :: IO ()
 main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
 
-runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.Task ByteString
+runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both (FilePath, Maybe Language)] -> Task.TaskEff ByteString
 runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs
 
-runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.Task ByteString
+runParse :: SomeRenderer TermRenderer -> Either Handle [(FilePath, Maybe Language)] -> Task.TaskEff ByteString
 runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
 
 -- | A parser for the application's command-line arguments.
 --
 --   Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
-arguments :: ParserInfo (Log.Options, Task.Task ())
+arguments :: ParserInfo (Log.Options, Task.TaskEff ())
 arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsParser)) description
   where
     version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program")

src/Semantic/Diff.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE GADTs #-}
+module Semantic.Diff where
+
+import Prologue hiding (MonadError(..))
+import Analysis.ConstructorName (ConstructorName, constructorLabel)
+import Analysis.IdentifierName (IdentifierName, identifierLabel)
+import Analysis.Declaration (HasDeclaration, declarationAlgebra)
+import Data.Blob
+import Data.Diff
+import Data.JSON.Fields
+import Data.Output
+import Data.Record
+import Data.Term
+import Diffing.Algorithm (Diffable)
+import Diffing.Interpreter
+import Parsing.Parser
+import Rendering.Renderer
+import Semantic.IO (NoLanguageForBlob(..))
+import Semantic.Stat as Stat
+import Semantic.Task as Task
+
+diffBlobPairs :: (Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs, Output output) => DiffRenderer output -> [BlobPair] -> Eff effs ByteString
+diffBlobPairs renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . diffBlobPair renderer) blobs
+  where toOutput' = case renderer of
+          JSONDiffRenderer -> toOutput . renderJSONDiffs
+          _ -> toOutput
+
+-- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'.
+diffBlobPair :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => DiffRenderer output -> BlobPair -> Eff effs output
+diffBlobPair renderer blobs
+  | Just (SomeParser parser) <- someParser (Proxy :: Proxy '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable]) <$> effectiveLanguage
+  = case renderer of
+    ToCDiffRenderer         -> run (WrapTask . (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)))                     diffTerms renderToCDiff
+    JSONDiffRenderer        -> run (WrapTask . (          parse parser      >=> decorate constructorLabel >=> decorate identifierLabel)) diffTerms renderJSONDiff
+    SExpressionDiffRenderer -> run (WrapTask . (          parse parser      >=> decorate constructorLabel . (Nil <$)))                   diffTerms (const renderSExpressionDiff)
+    DOTDiffRenderer         -> run (WrapTask .            parse parser)                                                                  diffTerms renderDOTDiff
+  | otherwise = throwError (SomeException (NoLanguageForBlob effectivePath))
+  where effectivePath = pathForBlobPair blobs
+        effectiveLanguage = languageForBlobPair blobs
+
+        run :: (Foldable syntax, Functor syntax) => Members [Distribute WrappedTask, Task, Telemetry, IO] effs => (Blob -> WrappedTask (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (BlobPair -> Diff syntax ann ann -> output) -> Eff effs output
+        run parse diff renderer = do
+          terms <- distributeFor blobs parse
+          time "diff" languageTag $ do
+            diff <- diffTermPair diff (runJoin terms)
+            writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
+            render (renderer blobs) diff
+          where
+            languageTag = languageTagForBlobPair blobs
+
+-- | A task to diff 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's.
+diffTermPair :: (Functor syntax, Member Task effs) => Differ syntax ann1 ann2 -> These (Term syntax ann1) (Term syntax ann2) -> Eff effs (Diff syntax ann1 ann2)
+diffTermPair _      (This  t1   ) = pure (deleting t1)
+diffTermPair _      (That     t2) = pure (inserting t2)
+diffTermPair differ (These t1 t2) = diff differ t1 t2

src/Semantic/Distribute.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
+module Semantic.Distribute
+( distribute
+, distributeFor
+, distributeFoldMap
+, Distribute
+, runDistribute
+, Action(..)
+) where
+
+import qualified Control.Concurrent.Async as Async
+import           Control.Monad.Effect hiding (run)
+import           Control.Monad.Effect.Exception
+import           Control.Monad.Effect.Run
+import           Control.Monad.IO.Class
+import           Control.Parallel.Strategies
+import           Prologue hiding (MonadError (..))
+
+-- | Distribute a 'Traversable' container of tasks over the available cores (i.e. execute them concurrently), collecting their results.
+--
+--   This is a concurrent analogue of 'sequenceA'.
+distribute :: (Member (Distribute task) effs, Traversable t) => t (task output) -> Eff effs (t output)
+distribute = send . Distribute
+
+-- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results.
+--
+--   This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped).
+distributeFor :: (Member (Distribute task) effs, Traversable t) => t a -> (a -> task output) -> Eff effs (t output)
+distributeFor inputs toTask = distribute (fmap toTask inputs)
+
+-- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), combining the results 'Monoid'ally into a final value.
+--
+--   This is a concurrent analogue of 'foldMap'.
+distributeFoldMap :: (Member (Distribute task) effs, Monoid output, Traversable t) => (a -> task output) -> t a -> Eff effs output
+distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
+
+
+-- | Distribute effects run tasks concurrently.
+data Distribute task output where
+  Distribute :: Traversable t => t (task output) -> Distribute task (t output)
+
+
+-- | Evaluate a 'Distribute' effect concurrently.
+runDistribute :: Members '[Exc SomeException, IO] effs => Eff (Distribute task ': effs) a -> Action task -> Eff effs a
+runDistribute m action = interpret (\ (Distribute tasks) ->
+  liftIO (Async.mapConcurrently (runAction action) tasks) >>= either throwError pure . sequenceA . withStrategy (parTraversable (parTraversable rseq))) m
+
+
+-- | An action evaluating @task@s to some output in 'IO', or failing with an exception.
+--
+--   This is necessary because GHC won’t allow us to use a rank-n quantified type in the third parameter to our instance of 'Run', below.
+newtype Action task = Action { runAction :: forall output . task output -> IO (Either SomeException output) }
+
+instance (Members '[Exc SomeException, IO] effects, Run effects result rest) => Run (Distribute task ': effects) result (Action task -> rest) where
+  run = fmap run . runDistribute

src/Semantic/IO.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables, TupleSections #-}
+{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TupleSections, TypeOperators, UndecidableInstances #-}
 module Semantic.IO
 ( readFile
 , readFilePair
@@ -8,23 +8,35 @@ module Semantic.IO
 , readBlobsFromPaths
 , readBlobsFromDir
 , languageForFilePath
+, NoLanguageForBlob(..)
+, readBlobs
+, readBlobPairs
+, writeToOutput
+, Files
+, runFiles
+, rethrowing
 ) where
 
-import Prologue hiding (fail)
-import Control.Monad.IO.Class
-import Data.Aeson
+import qualified Control.Exception as Exc
+import           Control.Monad.Effect hiding (run)
+import           Control.Monad.Effect.Exception
+import           Control.Monad.Effect.Run
+import           Control.Monad.IO.Class
+import           Data.Aeson
 import qualified Data.Blob as Blob
-import Data.Language
-import Data.Source
+import           Data.Bool
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
-import Prelude hiding (readFile)
-import System.Exit
-import System.FilePath
-import System.IO (Handle)
-import System.FilePath.Glob
-import System.Directory (doesDirectoryExist)
-import Text.Read
+import           Data.Language
+import           Data.Source
+import           Prelude hiding (readFile)
+import           Prologue hiding (MonadError (..), fail)
+import           System.Directory (doesDirectoryExist)
+import           System.Exit
+import           System.FilePath
+import           System.FilePath.Glob
+import           System.IO (Handle)
+import           Text.Read
 
 -- | Read a utf8-encoded file to a 'Blob'.
 readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m (Maybe Blob.Blob)
@@ -40,11 +52,11 @@ readFilePair a b = do
   case (before, after) of
     (Just a, Nothing) -> pure (Join (This a))
     (Nothing, Just b) -> pure (Join (That b))
-    (Just a, Just b) -> pure (Join (These a b))
-    _ -> fail "expected file pair with content on at least one side"
+    (Just a, Just b)  -> pure (Join (These a b))
+    _                 -> fail "expected file pair with content on at least one side"
 
 isDirectory :: MonadIO m => FilePath -> m Bool
-isDirectory path = liftIO (doesDirectoryExist path) >>= pure
+isDirectory path = liftIO (doesDirectoryExist path)
 
 -- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported.
 languageForFilePath :: FilePath -> Maybe Language
@@ -64,7 +76,7 @@ readBlobsFromHandle = fmap toBlobs . readFromHandle
   where toBlobs BlobParse{..} = fmap toBlob blobs
 
 readBlobsFromPaths :: MonadIO m => [(FilePath, Maybe Language)] -> m [Blob.Blob]
-readBlobsFromPaths files = catMaybes <$> traverse (uncurry Semantic.IO.readFile) files
+readBlobsFromPaths files = catMaybes <$> traverse (uncurry readFile) files
 
 readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
 readBlobsFromDir path = do
@@ -77,14 +89,14 @@ readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a
 readFromHandle h = do
   input <- liftIO $ BL.hGetContents h
   case eitherDecode input of
-    Left e -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
+    Left e  -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
     Right d -> pure d
 
 toBlob :: Blob -> Blob.Blob
 toBlob Blob{..} = Blob.sourceBlob path language' (fromText content)
   where language' = case language of
           "" -> languageForFilePath path
-          _ -> readMaybe language
+          _  -> readMaybe language
 
 
 newtype BlobDiff = BlobDiff { blobs :: [BlobPair] }
@@ -96,8 +108,8 @@ newtype BlobParse = BlobParse { blobs :: [Blob] }
 type BlobPair = Join These Blob
 
 data Blob = Blob
-  { path :: FilePath
-  , content :: Text
+  { path     :: FilePath
+  , content  :: Text
   , language :: String
   }
   deriving (Show, Generic, FromJSON)
@@ -107,7 +119,65 @@ instance FromJSON BlobPair where
     before <- o .:? "before"
     after <- o .:? "after"
     case (before, after) of
-      (Just b, Just a) -> pure $ Join (These b a)
+      (Just b, Just a)  -> pure $ Join (These b a)
       (Just b, Nothing) -> pure $ Join (This b)
       (Nothing, Just a) -> pure $ Join (That a)
-      _ -> fail "Expected object with 'before' and/or 'after' keys only"
+      _                 -> fail "Expected object with 'before' and/or 'after' keys only"
+
+
+-- | An exception indicating that we’ve tried to diff or parse a blob of unknown language.
+newtype NoLanguageForBlob = NoLanguageForBlob FilePath
+  deriving (Eq, Exception, Ord, Show, Typeable)
+
+
+-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
+readBlobs :: Member Files effs => Either Handle [(FilePath, Maybe Language)] -> Eff effs [Blob.Blob]
+readBlobs = send . ReadBlobs
+
+-- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
+readBlobPairs :: Member Files effs => Either Handle [Both (FilePath, Maybe Language)] -> Eff effs [Blob.BlobPair]
+readBlobPairs = send . ReadBlobPairs
+
+-- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
+writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs ()
+writeToOutput path = send . WriteToOutput path
+
+
+-- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's.
+data Files out where
+  ReadBlobs     :: Either Handle [(FilePath, Maybe Language)] -> Files [Blob.Blob]
+  ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Files [Blob.BlobPair]
+  WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
+
+-- | Run a 'Files' effect in 'IO'.
+runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a
+runFiles = interpret $ \ files -> case files of
+  ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle)
+  ReadBlobs (Right paths@[(path, Nothing)]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
+  ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)
+  ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
+  WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)
+
+
+instance (Members '[Exc SomeException, IO] effects, Run effects result rest) => Run (Files ': effects) result rest where
+  run = run . runFiles
+
+
+-- | Catch exceptions in 'IO' actions embedded in 'Eff', handling them with the passed function.
+--
+--   Note that while the type allows 'IO' to occur anywhere within the effect list, it must actually occur at the end to be able to run the computation.
+catchException :: ( Exc.Exception e
+                  , Member IO r
+                  )
+               => Eff r a
+               -> (e -> Eff r a)
+               -> Eff r a
+catchException m handler = interpose pure (\ m yield -> send (Exc.try m) >>= either handler yield) m
+
+-- | Lift an 'IO' action into 'Eff', catching and rethrowing any exceptions it throws into an 'Exc' effect.
+rethrowing :: ( Member (Exc SomeException) r
+              , Member IO r
+              )
+           => IO a
+           -> Eff r a
+rethrowing m = catchException (liftIO m) (throwError . toException @SomeException)

src/Semantic/Log.hs

@@ -1,17 +1,18 @@
 module Semantic.Log where
 
-import Prologue
-import Data.Error (withSGRCode)
-import Data.List (intersperse)
+import           Control.Monad.IO.Class
+import           Data.Error (withSGRCode)
+import           Data.List (intersperse)
 import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
 import qualified Data.Time.Format as Time
 import qualified Data.Time.LocalTime as LocalTime
-import Semantic.Queue
-import System.Console.ANSI
-import System.IO
-import System.Posix.Process
-import System.Posix.Types
-import Text.Printf
+import           Prologue
+import           Semantic.Queue
+import           System.Console.ANSI
+import           System.IO
+import           System.Posix.Process
+import           System.Posix.Types
+import           Text.Printf
 
 
 -- | A log message at a specific level.
@@ -27,14 +28,14 @@ data Level
 
 
 -- | Queue a message to be logged.
-queueLogMessage :: AsyncQueue Message Options -> Level -> String -> [(String, String)] -> IO ()
+queueLogMessage :: MonadIO io => AsyncQueue Message Options -> Level -> String -> [(String, String)] -> io ()
 queueLogMessage q@AsyncQueue{..} level message pairs
-  | Just logLevel <- optionsLevel asyncQueueExtra, level <= logLevel = Time.getCurrentTime >>= LocalTime.utcToLocalZonedTime >>= queue q . Message level message pairs
+  | Just logLevel <- optionsLevel asyncQueueExtra, level <= logLevel = liftIO Time.getCurrentTime >>= liftIO . LocalTime.utcToLocalZonedTime >>= liftIO . queue q . Message level message pairs
   | otherwise = pure ()
 
 -- | Log a message to stderr.
-logMessage :: Options -> Message -> IO ()
-logMessage options@Options{..} = hPutStr stderr . optionsFormatter options
+logMessage :: MonadIO io => Options -> Message -> io ()
+logMessage options@Options{..} = liftIO . hPutStr stderr . optionsFormatter options
 
 -- | Format log messaging using "logfmt".
 --
@@ -83,12 +84,12 @@ terminalFormatter Options{..} (Message level message pairs time) =
 -- | Options controlling logging, error handling, &c.
 data Options = Options
   { optionsEnableColour :: Bool -- ^ Whether to enable colour formatting for logging (Only works when logging to a terminal that supports ANSI colors).
-  , optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging.
-  , optionsRequestID :: Maybe String -- ^ Optional request id for tracing across systems.
-  , optionsIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime).
-  , optionsPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
-  , optionsFormatter :: Options -> Message -> String -- ^ Log formatter to use (set automaticaly at runtime).
-  , optionsProcessID :: CPid -- ^ ProcessID (set automaticaly at runtime).
+  , optionsLevel        :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging.
+  , optionsRequestID    :: Maybe String -- ^ Optional request id for tracing across systems.
+  , optionsIsTerminal   :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime).
+  , optionsPrintSource  :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
+  , optionsFormatter    :: Options -> Message -> String -- ^ Log formatter to use (set automaticaly at runtime).
+  , optionsProcessID    :: CPid -- ^ ProcessID (set automaticaly at runtime).
   }
 
 defaultOptions :: Options
@@ -102,8 +103,8 @@ defaultOptions = Options
   , optionsProcessID = 0
   }
 
-configureOptionsForHandle :: Handle -> Options -> IO Options
-configureOptionsForHandle handle options = do
+configureOptionsForHandle :: MonadIO io => Handle -> Options -> io Options
+configureOptionsForHandle handle options = liftIO $ do
   pid <- getProcessID
   isTerminal <- hIsTerminalDevice handle
   pure $ options

src/Semantic/Parse.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE GADTs #-}
+module Semantic.Parse where
+
+import Analysis.ConstructorName (ConstructorName, constructorLabel)
+import Analysis.IdentifierName (IdentifierName, identifierLabel)
+import Analysis.Declaration (HasDeclaration, declarationAlgebra)
+import Analysis.PackageDef (HasPackageDef, packageDefAlgebra)
+import Data.Blob
+import Data.JSON.Fields
+import Data.Output
+import Data.Record
+import Parsing.Parser
+import Prologue hiding (MonadError(..))
+import Rendering.Renderer
+import Semantic.IO (NoLanguageForBlob(..))
+import Semantic.Task
+
+parseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Output output) => TermRenderer output -> [Blob] -> Eff effs ByteString
+parseBlobs renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . parseBlob renderer) blobs
+  where toOutput' = case renderer of
+          JSONTermRenderer -> toOutput . renderJSONTerms
+          SymbolsTermRenderer _ -> toOutput . renderSymbolTerms
+          _ -> toOutput
+
+-- | A task to parse a 'Blob' and render the resulting 'Term'.
+parseBlob :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> Eff effs output
+parseBlob renderer blob@Blob{..}
+  | Just (SomeParser parser) <- someParser (Proxy :: Proxy '[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1]) <$> blobLanguage
+  = parse parser blob >>= case renderer of
+    JSONTermRenderer           -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)
+    SExpressionTermRenderer    -> decorate constructorLabel . (Nil <$)                   >=> render renderSExpressionTerm
+    TagsTermRenderer           -> decorate (declarationAlgebra blob)                     >=> render (renderToTags blob)
+    ImportsTermRenderer        -> decorate (declarationAlgebra blob) >=> decorate (packageDefAlgebra blob) >=> render (renderToImports blob)
+    SymbolsTermRenderer fields -> decorate (declarationAlgebra blob)                     >=> render (renderToSymbols fields blob)
+    DOTTermRenderer            ->                                                            render (renderDOTTerm blob)
+  | otherwise = throwError (SomeException (NoLanguageForBlob blobPath))

src/Semantic/Stat.hs

@@ -22,26 +22,28 @@ module Semantic.Stat
 ) where
 
 
-import Prologue
-import Data.List (intercalate)
-import Data.List.Split (splitOneOf)
-import Network.Socket (Socket(..), SocketType(..), socket, connect, close, getAddrInfo, addrFamily, addrAddress, defaultProtocol)
-import Network.Socket.ByteString
-import Network.URI
-import Numeric
+import           Control.Monad.IO.Class
 import qualified Data.ByteString.Char8 as B
-import System.Environment
-import System.IO.Error
+import           Data.List (intercalate)
+import           Data.List.Split (splitOneOf)
 import qualified Data.Time.Clock as Time
 import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
+import           Network.Socket
+    (Socket (..), SocketType (..), addrAddress, addrFamily, close, connect, defaultProtocol, getAddrInfo, socket)
+import           Network.Socket.ByteString
+import           Network.URI
+import           Numeric
+import           Prologue
+import           System.Environment
+import           System.IO.Error
 
 -- | A named piece of data you wish to record a specific 'Metric' for.
 -- See https://docs.datadoghq.com/guides/dogstatsd/ for more details.
 data Stat
   = Stat
-  { statName :: String  -- ^ Stat name, usually separated by '.' (e.g. "system.metric.name")
+  { statName  :: String  -- ^ Stat name, usually separated by '.' (e.g. "system.metric.name")
   , statValue :: Metric -- ^ 'Metric' value.
-  , statTags :: Tags    -- ^ Key/value 'Tags' (optional).
+  , statTags  :: Tags    -- ^ Key/value 'Tags' (optional).
   }
 
 -- | The various supported metric types in Datadog.
@@ -77,14 +79,13 @@ timing :: String -> Double -> Tags -> Stat
 timing n v = Stat n (Timer v)
 
 -- | Run an IO Action and record timing
-withTiming :: (Stat -> IO ()) -> String -> Tags -> IO a -> IO a
-withTiming statter name tags f = do
-  start <- Time.getCurrentTime
-  result <- f
-  end <- Time.getCurrentTime
+withTiming :: MonadIO io => String -> Tags -> io a -> io (a, Stat)
+withTiming name tags action = do
+  start <- liftIO Time.getCurrentTime
+  result <- action
+  end <- liftIO Time.getCurrentTime
   let duration = realToFrac (Time.diffUTCTime end start * 1000)
-  statter (timing name duration tags)
-  pure result
+  pure (result, timing name duration tags)
 
 -- | Histogram measurement.
 histogram :: String -> Double -> Tags -> Stat
@@ -99,8 +100,8 @@ data StatsClient
   = StatsClient
   { statsClientUDPSocket :: Socket
   , statsClientNamespace :: String
-  , statsClientUDPHost :: String
-  , statsClientUDPPort :: String
+  , statsClientUDPHost   :: String
+  , statsClientUDPPort   :: String
   }
 
 -- | Create a default stats client. This function consults two optional
@@ -108,8 +109,8 @@ data StatsClient
 --     * STATS_ADDR     - String URI to send stats to in the form of `host:port`.
 --     * DOGSTATSD_HOST - String hostname which will override the above host.
 --                        Generally used on kubes pods.
-defaultStatsClient :: IO StatsClient
-defaultStatsClient = do
+defaultStatsClient :: MonadIO io => io StatsClient
+defaultStatsClient = liftIO $ do
   addr <- lookupEnv "STATS_ADDR"
   let (host', port) = parseAddr (fmap ("statsd://" <>) addr)
 
@@ -130,20 +131,20 @@ defaultStatsClient = do
 
 
 -- | Create a StatsClient at the specified host and port with a namespace prefix.
-statsClient :: String -> String -> String -> IO StatsClient
-statsClient host port statsClientNamespace = do
+statsClient :: MonadIO io => String -> String -> String -> io StatsClient
+statsClient host port statsClientNamespace = liftIO $ do
   (addr:_) <- getAddrInfo Nothing (Just host) (Just port)
   sock <- socket (addrFamily addr) Datagram defaultProtocol
   connect sock (addrAddress addr)
   pure (StatsClient sock statsClientNamespace host port)
 
 -- | Close the client's underlying socket.
-closeStatClient :: StatsClient -> IO ()
-closeStatClient StatsClient{..} = close statsClientUDPSocket
+closeStatClient :: MonadIO io => StatsClient -> io ()
+closeStatClient StatsClient{..} = liftIO (close statsClientUDPSocket)
 
 -- | Send a stat over the StatsClient's socket.
-sendStat :: StatsClient -> Stat -> IO ()
-sendStat StatsClient{..} = void . tryIOError . sendAll statsClientUDPSocket . B.pack . renderDatagram statsClientNamespace
+sendStat :: MonadIO io => StatsClient -> Stat -> io ()
+sendStat StatsClient{..} = liftIO . void . tryIOError . sendAll statsClientUDPSocket . B.pack . renderDatagram statsClientNamespace
 
 
 -- Datagram Rendering
@@ -193,7 +194,7 @@ instance Render Tags where
   renders xs = renderString "|#" . (\x -> x <> intercalate "," (renderTag <$> xs))
     where
       renderTag (k, "") = k
-      renderTag (k, v) = k <> ":" <> v
+      renderTag (k, v)  = k <> ":" <> v
 
 instance Render Int where
   renders = shows

src/Semantic/Task.hs

@@ -1,82 +1,93 @@
-{-# LANGUAGE DataKinds, GADTs, MultiParamTypeClasses, TypeOperators #-}
+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
 module Semantic.Task
 ( Task
+, TaskEff
+, WrappedTask(..)
 , Level(..)
 , RAlgebra
 , Differ
-, readBlobs
-, readBlobPairs
-, writeToOutput
+-- * I/O
+, IO.readBlobs
+, IO.readBlobPairs
+, IO.writeToOutput
+-- * Telemetry
 , writeLog
 , writeStat
 , time
+-- * High-level flow
 , parse
+, parseModule
+, parseModules
+, parsePackage
+, analyze
 , decorate
 , diff
 , render
+, graphImports
+-- * Concurrency
 , distribute
 , distributeFor
 , distributeFoldMap
-, bidistribute
-, bidistributeFor
+-- * Configuration
 , defaultOptions
 , configureOptionsForHandle
 , terminalFormatter
 , logfmtFormatter
+-- * Interpreting
 , runTask
 , runTaskWithOptions
+-- * Re-exports
+, Distribute
+, Eff
+, Exc
+, throwError
+, SomeException
+, Telemetry
 ) where
 
-import Prologue
-import Analysis.Decorator (decoratorWithAlgebra)
+import qualified Analysis.Abstract.ImportGraph as Abstract
+import           Analysis.Abstract.Evaluating
+import           Analysis.Decorator (decoratorWithAlgebra)
 import qualified Assigning.Assignment as Assignment
-import Control.Monad.IO.Class
-import Control.Parallel.Strategies
-import qualified Control.Concurrent.Async as Async
-import Control.Monad.Free.Freer
-import Data.Blob
-import Data.Bool
+import qualified Control.Abstract.Analysis as Analysis
+import qualified Control.Exception as Exc
+import           Control.Monad.Effect.Exception
+import           Control.Monad.Effect.Internal as Eff hiding (run)
+import           Control.Monad.Effect.Reader
+import           Control.Monad.Effect.Run as Run
+import           Data.Abstract.Address
+import qualified Data.Abstract.Evaluatable as Analysis
+import           Data.Abstract.FreeVariables
+import           Data.Abstract.Located
+import           Data.Abstract.Module
+import           Data.Abstract.Package as Package
+import           Data.Abstract.Value (Value)
+import           Data.Blob
 import qualified Data.ByteString as B
-import Data.Diff
+import           Data.Diff
 import qualified Data.Error as Error
-import Data.Language
-import Data.Record
+import           Data.Record
 import qualified Data.Syntax as Syntax
-import Data.Term
-import Parsing.Parser
-import Parsing.CMark
-import Parsing.TreeSitter
-import System.Exit (die)
-import System.IO (Handle, stderr)
+import           Data.Term
+import           Parsing.CMark
+import           Parsing.Parser
+import           Parsing.TreeSitter
+import           Prologue hiding (MonadError(..))
+import           Semantic.Distribute
 import qualified Semantic.IO as IO
-import Semantic.Log
-import Semantic.Stat as Stat
-import Semantic.Queue
-
-
-data TaskF output where
-  ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob]
-  ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [BlobPair]
-  WriteToOutput :: Either Handle FilePath -> B.ByteString -> TaskF ()
-  WriteLog :: Level -> String -> [(String, String)] -> TaskF ()
-  WriteStat :: Stat -> TaskF ()
-  Time :: String -> [(String, String)] -> Task output -> TaskF output
-  Parse :: Parser term -> Blob -> TaskF term
-  Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields)))
-  Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> TaskF (Diff syntax ann1 ann2)
-  Render :: Renderer input output -> input -> TaskF output
-  Distribute :: Traversable t => t (Task output) -> TaskF (t output)
-  Bidistribute :: Bitraversable t => t (Task output1) (Task output2) -> TaskF (t output1 output2)
-
-  -- | For MonadIO.
-  LiftIO :: IO a -> TaskF a
-
-  -- | For MonadError.
-  Throw :: SomeException -> TaskF a
-  Catch :: Task a -> (SomeException -> Task a) -> TaskF a
+import           Semantic.Log
+import           Semantic.Queue
+import           Semantic.Stat as Stat
+import           Semantic.Telemetry
+import           System.Exit (die)
+import           System.IO (stderr)
 
 -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
-type Task = Freer TaskF
+type TaskEff = Eff '[Distribute WrappedTask, Task, IO.Files, Reader Options, Telemetry, Exc SomeException, IO]
+
+-- | A wrapper for a 'Task', to embed in other effects.
+newtype WrappedTask a = WrapTask { unwrapTask :: TaskEff a }
+  deriving (Applicative, Functor, Monad)
 
 -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types.
 type Differ syntax ann1 ann2 = Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
@@ -84,177 +95,139 @@ type Differ syntax ann1 ann2 = Term syntax ann1 -> Term syntax ann2 -> Diff synt
 -- | A function to render terms or diffs.
 type Renderer i o = i -> o
 
--- | A 'Task' which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
-readBlobs :: Either Handle [(FilePath, Maybe Language)] -> Task [Blob]
-readBlobs from = ReadBlobs from `Then` return
+-- | A task which parses a 'Blob' with the given 'Parser'.
+parse :: Member Task effs => Parser term -> Blob -> Eff effs term
+parse parser = send . Parse parser
 
--- | A 'Task' which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
-readBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> Task [BlobPair]
-readBlobPairs from = ReadBlobPairs from `Then` return
+-- | Parse a file into a 'Module'.
+parseModule :: Members '[IO.Files, Task] effs => Parser term -> Maybe FilePath -> FilePath -> Eff effs (Module term)
+parseModule parser rootDir path = do
+  blob <- head <$> IO.readBlobs (Right [(path, IO.languageForFilePath path)])
+  moduleForBlob rootDir blob <$> parse parser blob
 
--- | A 'Task' which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
-writeToOutput :: Either Handle FilePath -> B.ByteString -> Task ()
-writeToOutput path contents = WriteToOutput path contents `Then` return
+-- | Parse a list of files into 'Module's.
+parseModules :: Members '[IO.Files, Task] effs => Parser term -> FilePath -> [FilePath] -> Eff effs [Module term]
+parseModules parser rootDir = traverse (parseModule parser (Just rootDir))
 
--- | A 'Task' which logs a message at a specific log level to stderr.
-writeLog :: Level -> String -> [(String, String)] -> Task ()
-writeLog level message pairs = WriteLog level message pairs `Then` return
+-- | Parse a list of files into a 'Package'.
+parsePackage :: Members '[IO.Files, Task] effs => PackageName -> Parser term -> FilePath -> [FilePath] -> Eff effs (Package term)
+parsePackage name parser rootDir paths = Package (PackageInfo name Nothing) . Package.fromModules <$> parseModules parser rootDir paths
 
--- | A 'Task' which writes a stat.
-writeStat :: Stat -> Task ()
-writeStat stat = WriteStat stat `Then` return
 
--- | A 'Task' which measures and stats the timing of another 'Task'.
-time :: String -> [(String, String)] -> Task output -> Task output
-time statName tags task = Time statName tags task `Then` return
+-- | A task running some 'Analysis.MonadAnalysis' to completion.
+analyze :: Member Task effs => Analysis.SomeAnalysis m result -> Eff effs result
+analyze = send . Analyze
 
--- | A 'Task' which parses a 'Blob' with the given 'Parser'.
-parse :: Parser term -> Blob -> Task term
-parse parser blob = Parse parser blob `Then` return
+-- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
+decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Eff effs (Term f (Record (field ': fields)))
+decorate algebra = send . Decorate algebra
 
--- | A 'Task' which decorates a 'Term' with values computed using the supplied 'RAlgebra' function.
-decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
-decorate algebra term = Decorate algebra term `Then` return
+-- | A task which diffs a pair of terms using the supplied 'Differ' function.
+diff :: Member Task effs => Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Eff effs (Diff syntax ann1 ann2)
+diff differ term1 term2 = send (Semantic.Task.Diff differ term1 term2)
 
--- | A 'Task' which diffs a pair of terms using the supplied 'Differ' function.
-diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
-diff differ term1 term2 = Semantic.Task.Diff differ term1 term2 `Then` return
+-- | A task which renders some input using the supplied 'Renderer' function.
+render :: Member Task effs => Renderer input output -> input -> Eff effs output
+render renderer = send . Render renderer
 
--- | A 'Task' which renders some input using the supplied 'Renderer' function.
-render :: Renderer input output -> input -> Task output
-render renderer input = Render renderer input `Then` return
 
--- | Distribute a 'Traversable' container of 'Task's over the available cores (i.e. execute them concurrently), collecting their results.
---
---   This is a concurrent analogue of 'sequenceA'.
-distribute :: Traversable t => t (Task output) -> Task (t output)
-distribute tasks = Distribute tasks `Then` return
+-- | Render and serialize the import graph for a given 'Package'.
+graphImports :: (Apply Eq1 syntax, Apply Analysis.Evaluatable syntax, Apply FreeVariables1 syntax, Apply Functor syntax, Apply Ord1 syntax, Apply Show1 syntax, Member Syntax.Identifier syntax, Members '[Exc SomeException, Task] effs, Ord ann, Show ann) => Package (Term (Union syntax) ann) -> Eff effs B.ByteString
+graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= renderGraph
+  where asAnalysisForTypeOfPackage :: Abstract.ImportGraphing (Evaluating (Located Precise term) term (Value (Located Precise term))) effects value -> Package term -> Abstract.ImportGraphing (Evaluating (Located Precise term) term (Value (Located Precise term))) effects value
+        asAnalysisForTypeOfPackage = const
 
--- | Distribute a 'Bitraversable' container of 'Task's over the available cores (i.e. execute them concurrently), collecting their results.
---
---   This is a concurrent analogue of 'bisequenceA'.
-bidistribute :: Bitraversable t => t (Task output1) (Task output2) -> Task (t output1 output2)
-bidistribute tasks = Bidistribute tasks `Then` return
+        renderGraph result = case result of
+          (Right (Right (Right (Right (Right (_, graph))))), _) -> pure $! Abstract.renderImportGraph graph
+          _ -> throwError (toException (Exc.ErrorCall "graphImports: import graph rendering failed"))
 
--- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), collecting the results.
---
---   This is a concurrent analogue of 'for' or 'traverse' (with the arguments flipped).
-distributeFor :: Traversable t => t a -> (a -> Task output) -> Task (t output)
-distributeFor inputs toTask = distribute (fmap toTask inputs)
-
--- | Distribute the application of a function to each element of a 'Bitraversable' container of inputs over the available cores (i.e. perform the functions concurrently for each element), collecting the results.
---
---   This is a concurrent analogue of 'bifor' or 'bitraverse' (with the arguments flipped).
-bidistributeFor :: Bitraversable t => t a b -> (a -> Task output1) -> (b -> Task output2) -> Task (t output1 output2)
-bidistributeFor inputs toTask1 toTask2 = bidistribute (bimap toTask1 toTask2 inputs)
-
--- | Distribute the application of a function to each element of a 'Traversable' container of inputs over the available cores (i.e. perform the function concurrently for each element), combining the results 'Monoid'ally into a final value.
---
---   This is a concurrent analogue of 'foldMap'.
-distributeFoldMap :: (Traversable t, Monoid output) => (a -> Task output) -> t a -> Task output
-distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs))
 
 -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
 --
 -- > runTask = runTaskWithOptions defaultOptions
-runTask :: Task a -> IO a
+runTask :: TaskEff a -> IO a
 runTask = runTaskWithOptions defaultOptions
 
-
--- | Execute a 'Task' with the passed 'Options', yielding its result value in 'IO'.
-runTaskWithOptions :: Options -> Task a -> IO a
+-- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'.
+runTaskWithOptions :: Options -> TaskEff a -> IO a
 runTaskWithOptions options task = do
   options <- configureOptionsForHandle stderr options
   statter <- defaultStatsClient >>= newQueue sendStat
   logger <- newQueue logMessage options
 
-  result <- withTiming (queue statter) "run" [] $
-    run options logger statter task
+  (result, stat) <- withTiming "run" [] $ do
+    let run :: TaskEff a -> IO (Either SomeException a)
+        run task = Run.run task (Action (run . unwrapTask)) options (Queues logger statter)
+    run task
+  queue statter stat
 
   closeQueue statter
   closeStatClient (asyncQueueExtra statter)
   closeQueue logger
   either (die . displayException) pure result
-  where
-    run :: Options
-        -> AsyncQueue Message Options
-        -> AsyncQueue Stat StatsClient
-        -> Task a
-        -> IO (Either SomeException a)
-    run options logger statter = go
-      where
-        go :: Task a -> IO (Either SomeException a)
-        go = iterFreerA (\ yield task -> case task of
-          ReadBlobs (Left handle) -> (IO.readBlobsFromHandle handle >>= yield) `catchError` (pure . Left . toException)
-          ReadBlobs (Right paths@[(path, Nothing)]) -> (IO.isDirectory path >>= bool (IO.readBlobsFromPaths paths) (IO.readBlobsFromDir path) >>= yield) `catchError` (pure . Left . toException)
-          ReadBlobs (Right paths) -> (IO.readBlobsFromPaths paths >>= yield) `catchError` (pure . Left . toException)
-          ReadBlobPairs source -> (either IO.readBlobPairsFromHandle (traverse (runBothWith IO.readFilePair)) source >>= yield) `catchError` (pure . Left . toException)
-          WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
-          WriteLog level message pairs -> queueLogMessage logger level message pairs >>= yield
-          WriteStat stat -> queue statter stat >>= yield
-          Time statName tags task -> withTiming (queue statter) statName tags (go task) >>= either (pure . Left) yield
-          Parse parser blob -> go (runParser options blob parser) >>= either (pure . Left) yield
-          Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield
-          Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2) >>= yield
-          Render renderer input -> pure (renderer input) >>= yield
-          Distribute tasks -> Async.mapConcurrently go tasks >>= either (pure . Left) yield . sequenceA . withStrategy (parTraversable (parTraversable rseq))
-          Bidistribute tasks -> Async.runConcurrently (bitraverse (Async.Concurrently . go) (Async.Concurrently . go) tasks) >>= either (pure . Left) yield . bisequenceA . withStrategy (parBitraversable (parTraversable rseq) (parTraversable rseq))
-          LiftIO action -> action >>= yield
-          Throw err -> pure (Left err)
-          Catch during handler -> do
-            result <- go during
-            case result of
-              Left err -> go (handler err) >>= either (pure . Left) yield
-              Right a -> yield a) . fmap Right
 
-        parBitraversable :: Bitraversable t => Strategy a -> Strategy b -> Strategy (t a b)
-        parBitraversable strat1 strat2 = bitraverse (rparWith strat1) (rparWith strat2)
 
-runParser :: Options -> Blob -> Parser term -> Task term
-runParser Options{..} blob@Blob{..} = go
-  where
-    go :: Parser term -> Task term
-    go parser = case parser of
-      ASTParser language ->
-        time "parse.tree_sitter_ast_parse" languageTag $
-          liftIO ((Right <$> parseToAST language blob) `catchError` (pure . Left . toException)) >>= either throwError pure
-      AssignmentParser parser assignment -> do
-        ast <- go parser `catchError` \ err -> do
-          writeStat (Stat.increment "parse.parse_failures" languageTag)
-          writeLog Error "failed parsing" (("task", "parse") : blobFields)
-          throwError err
-        time "parse.assign" languageTag $
-          case Assignment.assign blobSource assignment ast of
-            Left err -> do
-              writeStat (Stat.increment "parse.assign_errors" languageTag)
-              writeLog Error (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) (("task", "assign") : blobFields)
-              throwError (toException err)
-            Right term -> do
-              for_ (errors term) $ \ err -> case Error.errorActual err of
-                  (Just "ParseError") -> do
-                    writeStat (Stat.increment "parse.parse_errors" languageTag)
-                    writeLog Warning (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) (("task", "parse") : blobFields)
-                  _ -> do
-                    writeStat (Stat.increment "parse.assign_warnings" languageTag)
-                    writeLog Warning (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) (("task", "assign") : blobFields)
-              writeStat (Stat.count "parse.nodes" (length term) languageTag)
-              pure term
-      MarkdownParser ->
-        time "parse.cmark_parse" languageTag $
-          let term = cmarkParser blobSource
-          in length term `seq` pure term
-    blobFields = ("path", blobPath) : languageTag
-    languageTag = maybe [] (pure . (,) ("language" :: String) . show) blobLanguage
-    errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String]
-    errors = cata $ \ (In a syntax) -> case syntax of
-      _ | Just err@Syntax.Error{} <- prj syntax -> [Syntax.unError (getField a) err]
-      _ -> fold syntax
+-- | An effect describing high-level tasks to be performed.
+data Task output where
+  Parse    :: Parser term -> Blob -> Task term
+  Analyze  :: Analysis.SomeAnalysis m result -> 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)))
+  Diff     :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
+  Render   :: Renderer input output -> input -> Task output
 
-instance MonadIO Task where
-  liftIO action = LiftIO action `Then` return
+-- | Run a 'Task' effect by performing the actions in 'IO'.
+runTaskF :: Members '[Reader Options, Telemetry, Exc SomeException, IO] effs => Eff (Task ': effs) a -> Eff effs a
+runTaskF = interpret $ \ task -> case task of
+  Parse parser blob -> runParser blob parser
+  Analyze analysis -> pure (Analysis.runSomeAnalysis analysis)
+  Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
+  Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2)
+  Render renderer input -> pure (renderer input)
 
-instance MonadError SomeException Task where
-  throwError error = Throw error `Then` return
-  catchError during handler = Catch during handler `Then` return
 
-{-# ANN module ("HLint: ignore Avoid return" :: String) #-}
+-- | Log an 'Error.Error' at the specified 'Level'.
+logError :: Member Telemetry effs => Options -> Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs ()
+logError Options{..} level blob err = writeLog level (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err)
+
+-- | Parse a 'Blob' in 'IO'.
+runParser :: Members '[Reader Options, Telemetry, Exc SomeException, IO] effs => Blob -> Parser term -> Eff effs term
+runParser blob@Blob{..} parser = case parser of
+  ASTParser language ->
+    time "parse.tree_sitter_ast_parse" languageTag $
+      IO.rethrowing (parseToAST language blob)
+  AssignmentParser parser assignment -> do
+    ast <- runParser blob parser `catchError` \ (SomeException err) -> do
+      writeStat (Stat.increment "parse.parse_failures" languageTag)
+      writeLog Error "failed parsing" (("task", "parse") : blobFields)
+      throwError (toException err)
+    options <- ask
+    time "parse.assign" languageTag $
+      case Assignment.assign blobSource assignment ast of
+        Left err -> do
+          writeStat (Stat.increment "parse.assign_errors" languageTag)
+          logError options Error blob err (("task", "assign") : blobFields)
+          throwError (toException err)
+        Right term -> do
+          for_ (errors term) $ \ err -> case Error.errorActual err of
+              Just "ParseError" -> do
+                writeStat (Stat.increment "parse.parse_errors" languageTag)
+                logError options Warning blob err (("task", "parse") : blobFields)
+              _ -> do
+                writeStat (Stat.increment "parse.assign_warnings" languageTag)
+                logError options Warning blob err (("task", "assign") : blobFields)
+          writeStat (Stat.count "parse.nodes" (length term) languageTag)
+          pure term
+  MarkdownParser ->
+    time "parse.cmark_parse" languageTag $
+      let term = cmarkParser blobSource
+      in length term `seq` pure term
+  where blobFields = ("path", blobPath) : languageTag
+        languageTag = maybe [] (pure . (,) ("language" :: String) . show) blobLanguage
+        errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Union fs) (Record Assignment.Location) -> [Error.Error String]
+        errors = cata $ \ (In a syntax) -> case syntax of
+          _ | Just err@Syntax.Error{} <- prj syntax -> [Syntax.unError (getField a) err]
+          _ -> fold syntax
+
+
+instance (Members '[Reader Options, Telemetry, Exc SomeException, IO] effects, Run effects result rest) => Run (Task ': effects) result rest where
+  run = run . runTaskF

src/Semantic/Telemetry.hs

@@ -0,0 +1,69 @@
+{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
+module Semantic.Telemetry
+( writeLog
+, writeStat
+, time
+, Telemetry
+, Queues(..)
+, runTelemetry
+, ignoreTelemetry
+) where
+
+import Control.Monad.Effect.Internal hiding (run)
+import Control.Monad.Effect.Reader
+import Control.Monad.Effect.Run
+import Control.Monad.IO.Class
+import Prologue
+import Semantic.Log
+import Semantic.Queue
+import Semantic.Stat
+
+-- | A task which logs a message at a specific log level to stderr.
+writeLog :: Member Telemetry effs => Level -> String -> [(String, String)] -> Eff effs ()
+writeLog level message pairs = send (WriteLog level message pairs)
+
+-- | A task which writes a stat.
+writeStat :: Member Telemetry effs => Stat -> Eff effs ()
+writeStat stat = send (WriteStat stat)
+
+-- | 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 statName tags task = do
+  (a, stat) <- withTiming statName tags task
+  a <$ writeStat stat
+
+
+-- | Statting and logging effects.
+data Telemetry output where
+  WriteStat :: Stat                                  -> Telemetry ()
+  WriteLog  :: Level -> String -> [(String, String)] -> Telemetry ()
+
+-- | Queues for logging and statting.
+data Queues = Queues { logger :: AsyncQueue Message Options, statter :: AsyncQueue Stat StatsClient }
+
+-- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
+runTelemetry :: Member IO (Reader Queues ': effs) => Eff (Telemetry ': effs) a -> Eff (Reader Queues ': effs) a
+runTelemetry = reinterpret (\ t -> case t of
+  WriteStat stat -> asks statter >>= \ statter -> liftIO (queue statter stat)
+  WriteLog level message pairs -> asks logger >>= \ logger -> queueLogMessage logger level message pairs)
+
+-- | Run a 'Telemetry' effect by ignoring statting/logging.
+ignoreTelemetry :: Eff (Telemetry ': effs) a -> Eff effs a
+ignoreTelemetry = interpret (\ t -> case t of
+  WriteStat{} -> pure ()
+  WriteLog{}  -> pure ())
+
+
+-- | Interpret an effect by replacing it with another effect.
+reinterpret :: (forall x. effect x -> Eff (newEffect ': effs) x)
+            -> Eff (effect ': effs) a
+            -> Eff (newEffect ': effs) a
+reinterpret handle = loop
+  where loop (Val x)  = pure x
+        loop (E u' q) = case decompose u' of
+            Right eff -> handle eff >>=            q >>> loop
+            Left  u   -> E (weaken u) (tsingleton (q >>> loop))
+
+
+instance (Member IO (Reader Queues ': effects), Run (Reader Queues ': effects) result rest) => Run (Telemetry ': effects) result rest where
+  run = run . runTelemetry

src/Semantic/Util.hs

@@ -35,9 +35,10 @@ import qualified GHC.TypeLits as TypeLevel
 import Language.Preluded
 import Parsing.Parser
 import Prologue
-import Semantic
+import Semantic.Diff (diffTermPair)
 import Semantic.IO as IO
-import Semantic.Task
+import Semantic.Task hiding (parsePackage)
+import qualified Semantic.Task as Task
 import System.FilePath.Posix
 
 import qualified Language.Go.Assignment as Go
@@ -123,7 +124,7 @@ parseFiles :: Parser term -> FilePath -> [FilePath] -> IO [Module term]
 parseFiles parser rootDir = traverse (parseFile parser (Just rootDir))
 
 parsePackage :: PackageName -> Parser term -> FilePath -> [FilePath] -> IO (Package term)
-parsePackage name parser rootDir files = Package (PackageInfo name Nothing) . Package.fromModules <$> parseFiles parser rootDir files
+parsePackage name parser rootDir = runTask . Task.parsePackage name parser rootDir
 
 
 -- Read a file from the filesystem into a Blob.
@@ -131,32 +132,17 @@ file :: MonadIO m => FilePath -> m Blob
 file path = fromJust <$> IO.readFile path (languageForFilePath path)
 
 -- Diff helpers
-diffWithParser ::
-               ( HasField fields Data.Span.Span
-               , HasField fields Range
-               , Eq1 syntax
-               , Show1 syntax
-               , Traversable syntax
-               , Diffable syntax
-               , GAlign syntax
-               , HasDeclaration syntax
-               )
+diffWithParser :: ( HasField fields Data.Span.Span
+                  , HasField fields Range
+                  , Eq1 syntax
+                  , Show1 syntax
+                  , Traversable syntax
+                  , Diffable syntax
+                  , GAlign syntax
+                  , HasDeclaration syntax
+                  , Members '[Distribute WrappedTask, Task] effs
+                  )
                => Parser (Term syntax (Record fields))
                -> BlobPair
-               -> Task (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
-diffWithParser parser = run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob))
-  where
-    run parse blobs = bidistributeFor (runJoin blobs) parse parse >>= diffTermPair diffTerms
-
-diffBlobWithParser ::
-                   ( HasField fields Data.Span.Span
-                   , HasField fields Range
-                   , Traversable syntax
-                   , HasDeclaration syntax
-                   )
-                  => Parser (Term syntax (Record fields))
-                  -> Blob
-                  -> Task (Term syntax (Record (Maybe Declaration : fields)))
-diffBlobWithParser parser = run (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob))
-  where
-    run parse = parse
+               -> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
+diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= diffTermPair diffTerms . runJoin

test/Data/Scientific/Spec.hs

@@ -0,0 +1,49 @@
+module Data.Scientific.Spec where
+
+import Data.Scientific.Exts
+import Data.Either
+import SpecHelpers
+
+spec :: Spec
+spec = describe "Scientific parsing" $ do
+
+  let go cases = forM_ cases $ \(s, v) -> parseScientific s `shouldBe` Right v
+
+  -- TODO: hexadecimal floats, someday (0x1.999999999999ap-4)
+
+  it "should handle Python floats" $
+    go [ ("-.6_6", -0.66)
+       , ("+.1_1", 0.11)
+       , ("123.4123", 123.4123)
+       , ("123.123J", 123.123) -- TODO: handle complex values separately in the parser
+       , ("1_1.3_1", 11.31)
+       , ("1_1.", 11.0)
+       , ("99E+01", 99e1)
+       , ("1e+3_4j", 1e34)
+       , ("3.e14", 3e14)
+       , (".3e1_4", 0.3e14)
+       , ("1_0.l", 10) -- this and the subsequent ones don't actually seem to be valid syntax, we should fix this in tree-sitter
+       , (".3", 0.3)
+       , (".1l", 0.1)  -- omitting a leading 0 is deprecated in python 3, also note that the -l suffix is not valid in Python 3
+       ]
+
+  it "should handle Ruby floats" $
+    go [ ("1.234_5e1_0", 1.2345e10)
+       , ("1E30", 1e30)
+       , ("1.2i", 1.2)
+       , ("1.0e+6", 1.0e6)
+       , ("1.0e-6", 1.0e-6)
+       ]
+
+  it "should handle JS numbers, including multiple bases" $
+    go [ ("101", 101)
+       , ("3.14", 3.14)
+       , ("3.14e+1", 3.14e1)
+       , ("0x1ABCDEFabcdef", 470375954370031)
+       , ("0o7632157312", 1047060170)
+       , ("0b1010101001", 681)
+       ]
+
+  it "should not accept truly bad input" $ do
+    parseScientific "." `shouldSatisfy` isLeft
+    parseScientific ""  `shouldSatisfy` isLeft

test/Semantic/CLI/Spec.hs

@@ -38,9 +38,9 @@ parseFixtures =
   where pathMode = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby)]
         pathMode' = Right [("test/fixtures/ruby/and-or.A.rb", Just Ruby), ("test/fixtures/ruby/and-or.B.rb", Just Ruby)]
 
-        sExpressionParseTreeOutput = "(Program\n  (And\n    (Identifier)\n    (Identifier)))\n"
-        jsonParseTreeOutput = "{\"trees\":[{\"path\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"And\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]}\n"
-        jsonParseTreeOutput' = "{\"trees\":[{\"path\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"And\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"Or\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"And\",\"children\":[{\"category\":\"Or\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"b\",\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"c\",\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]}\n"
+        sExpressionParseTreeOutput = "(Program\n  (LowAnd\n    (Identifier)\n    (Identifier)))\n"
+        jsonParseTreeOutput = "{\"trees\":[{\"path\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]}\n"
+        jsonParseTreeOutput' = "{\"trees\":[{\"path\":\"test/fixtures/ruby/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"LowAnd\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"b\",\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"c\",\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]}\n"
         emptyJsonParseTreeOutput = "{\"trees\":[]}\n"
         symbolsOutput = "{\"files\":[{\"path\":\"test/fixtures/ruby/method-declaration.A.rb\",\"symbols\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"kind\":\"Method\",\"symbol\":\"foo\"}],\"language\":\"Ruby\"}]}\n"
         tagsOutput = "[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"path\":\"test/fixtures/ruby/method-declaration.A.rb\",\"kind\":\"Method\",\"symbol\":\"foo\",\"line\":\"def foo\",\"language\":\"Ruby\"}]\n"

test/Spec.hs

@@ -9,6 +9,7 @@ import qualified Assigning.Assignment.Spec
 import qualified Data.Diff.Spec
 import qualified Data.Functor.Classes.Generic.Spec
 import qualified Data.Mergeable.Spec
+import qualified Data.Scientific.Spec
 import qualified Data.Source.Spec
 import qualified Data.Term.Spec
 import qualified Diffing.Algorithm.RWS.Spec
@@ -36,6 +37,7 @@ main = hspec $ do
     describe "Data.Diff" Data.Diff.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.Source" Data.Source.Spec.spec
     describe "Data.Term" Data.Term.Spec.spec
     describe "Diffing.Algorithm.RWS" Diffing.Algorithm.RWS.Spec.spec

test/SpecHelpers.hs

@@ -27,8 +27,9 @@ import Data.Span as X
 import Data.Term as X
 import Parsing.Parser as X
 import Rendering.Renderer as X
-import Semantic as X
-import Semantic.Task as X
+import Semantic.Diff as X
+import Semantic.Parse as X
+import Semantic.Task as X hiding (parsePackage)
 import Semantic.Util as X
 import System.FilePath as X
 

test/fixtures/ruby/and-or.diffA-B.txt

@@ -1,12 +1,11 @@
 (Program
-{ (And
-  {-(Identifier)-}
-  {-(Identifier)-})
-->(Or
+{+(LowOr
   {+(Identifier)+}
-  {+(Identifier)+}) }
-{+(And
-  {+(Or
+  {+(Identifier)+})+}
+  (LowAnd
+  { (Identifier)
+  ->(LowOr
     {+(Identifier)+}
-    {+(Identifier)+})+}
-  {+(Identifier)+})+})
+    {+(Identifier)+}) }
+  { (Identifier)
+  ->(Identifier) }))

test/fixtures/ruby/and-or.diffB-A.txt

@@ -1,12 +1,12 @@
 (Program
-{ (Or
-  {-(Identifier)-}
-  {-(Identifier)-})
-->(And
+{+(LowAnd
   {+(Identifier)+}
-  {+(Identifier)+}) }
-{-(And
-  {-(Or
+  {+(Identifier)+})+}
+{-(LowOr
+  {-(Identifier)-}
+  {-(Identifier)-})-}
+{-(LowAnd
+  {-(LowOr
     {-(Identifier)-}
     {-(Identifier)-})-}
   {-(Identifier)-})-})

test/fixtures/ruby/and-or.parseA.txt

@@ -1,4 +1,4 @@
 (Program
-  (And
+  (LowAnd
     (Identifier)
     (Identifier)))

test/fixtures/ruby/and-or.parseB.txt

@@ -1,9 +1,9 @@
 (Program
-  (Or
+  (LowOr
     (Identifier)
     (Identifier))
-  (And
-    (Or
+  (LowAnd
+    (LowOr
       (Identifier)
       (Identifier))
     (Identifier)))

vendor/effects

@@ -1 +1 @@
-Subproject commit 215ac5be57258a786959dac391db6bef83a70f28
+Subproject commit c316bd2d25fc562bbd49baf844d6587c497ede19

vendor/haskell-tree-sitter

@@ -1 +1 @@
-Subproject commit e1b1ce6185ce009c0039f9e86ecc694d2b603fd3
+Subproject commit 3b06fc65be9708336e003e43fb6b57d3da4b17f7