Merge branch 'master' into haskell-assignment2

semantic.cabal

@@ -152,6 +152,7 @@ library
                      , Semantic.CLI
                      , Semantic.Diff
                      , Semantic.Distribute
+                     , Semantic.Env
                      , Semantic.Graph
                      , Semantic.IO
                      , Semantic.Log

src/Data/Blob.hs

@@ -21,7 +21,6 @@ import Data.JSON.Fields
 import Data.Language
 import Data.Source as Source
 
-
 -- | The source, path, and language of a blob.
 data Blob = Blob
   { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
@@ -30,16 +29,36 @@ data Blob = Blob
   }
   deriving (Show, Eq, Generic, Message, Named)
 
+instance FromJSON Blob where
+  parseJSON = withObject "Blob" $ \b -> inferringLanguage
+    <$> b .: "content"
+    <*> b .: "path"
+    <*> b .: "language"
+
 nullBlob :: Blob -> Bool
 nullBlob Blob{..} = nullSource blobSource
 
 sourceBlob :: FilePath -> Language -> Source -> Blob
 sourceBlob filepath language source = Blob source filepath language
 
+inferringLanguage :: Source -> FilePath -> Language -> Blob
+inferringLanguage src pth lang
+  | knownLanguage lang = Blob src pth lang
+  | otherwise = Blob src pth (languageForFilePath pth)
+
 -- | Represents a blobs suitable for diffing which can be either a blob to
 -- delete, a blob to insert, or a pair of blobs to diff.
 type BlobPair = Join These Blob
 
+instance FromJSON BlobPair where
+  parseJSON = withObject "BlobPair" $ \o -> do
+    before <- o .:? "before"
+    after <- o .:? "after"
+    case (before, after) of
+      (Just b, Just a)  -> pure $ Join (These b a)
+      (Just b, Nothing) -> pure $ Join (This b)
+      (Nothing, Just a) -> pure $ Join (That a)
+      _                 -> Prelude.fail "Expected object with 'before' and/or 'after' keys only"
 
 blobPairDiffing :: Blob -> Blob -> BlobPair
 blobPairDiffing a b = Join (These a b)

src/Data/Language.hs

@@ -1,9 +1,11 @@
 {-# LANGUAGE DeriveAnyClass, DeriveGeneric, LambdaCase #-}
 module Data.Language where
 
-import Data.Aeson
-import Prologue
-import Proto3.Suite
+import           Data.Aeson
+import qualified Data.Text as T
+import           Prologue
+import           Proto3.Suite
+import           System.FilePath.Posix
 
 -- | The various languages we support.
 -- Please do not reorder any of the field names: the current implementation of 'Primitive'
@@ -23,6 +25,21 @@ data Language
     | PHP
     deriving (Eq, Generic, Ord, Read, Show, Bounded, ToJSON, Named, Enum, Finite, MessageField)
 
+instance FromJSON Language where
+  parseJSON = withText "Language" $ \l -> pure $ case T.toLower l of
+    "go"         -> Go
+    "haskell"    -> Haskell
+    "java"       -> Java
+    "javascript" -> JavaScript
+    "json"       -> JSON
+    "jsx"        -> JSX
+    "markdown"   -> Markdown
+    "python"     -> Python
+    "ruby"       -> Ruby
+    "typescript" -> TypeScript
+    "php"        -> PHP
+    _            -> Unknown
+
 -- | Predicate failing on 'Unknown' and passing in all other cases.
 knownLanguage :: Language -> Bool
 knownLanguage = (/= Unknown)
@@ -72,3 +89,7 @@ extensionsForLanguage language = case language of
   Ruby       -> [".rb"]
   TypeScript -> [".ts", ".tsx", ".d.tsx"]
   _          -> []
+
+-- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported.
+languageForFilePath :: FilePath -> Language
+languageForFilePath = languageForType . takeExtension

src/Data/Source.hs

@@ -28,6 +28,7 @@ module Data.Source
 
 import Prologue
 import Data.Array
+import Data.Aeson (FromJSON (..), withText)
 import qualified Data.ByteString as B
 import Data.Char (ord)
 import Data.List (span)
@@ -47,6 +48,8 @@ newtype Source = Source { sourceBytes :: B.ByteString }
 fromUTF8 :: B.ByteString -> Source
 fromUTF8 = Source
 
+instance FromJSON Source where
+  parseJSON = withText "Source" (pure . fromText)
 
 -- Measurement
 

src/Language/Haskell/Assignment.hs

@@ -38,14 +38,13 @@ type Syntax = '[
   , Syntax.AllConstructors
   , Syntax.AnnotatedTypeVariable
   , Syntax.Class
-  , Syntax.ConstructorIdentifier
-  , Syntax.ConstructorOperator
   , Syntax.ConstructorSymbol
   , Syntax.Context
   , Syntax.Context'
   , Syntax.DefaultDeclaration
   , Syntax.Deriving
   , Syntax.Empty
+  , Syntax.EntityIdentifier
   , Syntax.Error
   , Syntax.EqualityConstraint
   , Syntax.Export
@@ -67,11 +66,9 @@ type Syntax = '[
   , Syntax.ListConstructor
   , Syntax.Module
   , Syntax.ModuleExport
-  , Syntax.ModuleIdentifier
   , Syntax.NewType
+  , Syntax.Operator
   , Syntax.Pragma
-  , Syntax.PrimitiveConstructorIdentifier
-  , Syntax.PrimitiveVariableIdentifier
   , Syntax.QualifiedImportDeclaration
   , Syntax.QualifiedModuleIdentifier
   , Syntax.QualifiedTypeConstructorIdentifier
@@ -84,17 +81,11 @@ type Syntax = '[
   , Syntax.StrictTypeVariable
   , Syntax.TupleConstructor
   , Syntax.Type
-  , Syntax.TypeClassIdentifier
   , Syntax.TypeConstructorExport
-  , Syntax.TypeConstructorIdentifier
-  , Syntax.TypeOperator
   , Syntax.TypePattern
   , Syntax.TypeSignature
   , Syntax.TypeSynonym
-  , Syntax.TypeVariableIdentifier
   , Syntax.UnitConstructor
-  , Syntax.VariableIdentifier
-  , Syntax.VariableOperator
   , Syntax.VariableSymbol
   , Type.TypeParameters
   , []

src/Language/Haskell/Syntax.hs

@@ -281,15 +281,6 @@ instance Show1 TypeConstructorExport where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable TypeConstructorExport
 
-newtype VariableOperator a = VariableOperator { variableOperatorContent :: a }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
-
-instance Eq1 VariableOperator where liftEq = genericLiftEq
-instance Ord1 VariableOperator where liftCompare = genericLiftCompare
-instance Show1 VariableOperator where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable VariableOperator
-
 data AllConstructors a = AllConstructors
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
 
@@ -299,15 +290,6 @@ instance Show1 AllConstructors where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable AllConstructors
 
-newtype ConstructorOperator a = ConstructorOperator { constructorOperatorContent :: a }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
-
-instance Eq1 ConstructorOperator where liftEq = genericLiftEq
-instance Ord1 ConstructorOperator where liftCompare = genericLiftCompare
-instance Show1 ConstructorOperator where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable ConstructorOperator
-
 data InfixOperatorPattern a = InfixOperatorPattern { infixOperatorPatternLeft :: a, infixOperatorPatternOperator :: a, infixOperatorPatternRight :: a }
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
 
@@ -371,77 +353,32 @@ instance Show1 EqualityConstraint where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable EqualityConstraint
 
-newtype TypeVariableIdentifier a = TypeVariableIdentifier { typeVariableIdentifiername :: Name }
+data EntityIdentifier a = TypeVariableIdentifier Name
+                        | TypeConstructorIdentifier Name
+                        | ModuleIdentifier Name
+                        | ConstructorIdentifier Name
+                        | TypeClassIdentifier Name
+                        | VariableIdentifier Name
+                        | PrimitiveConstructorIdentifier Name
+                        | PrimitiveVariableIdentifier Name
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
 
-instance Eq1 TypeVariableIdentifier where liftEq = genericLiftEq
-instance Ord1 TypeVariableIdentifier where liftCompare = genericLiftCompare
-instance Show1 TypeVariableIdentifier where liftShowsPrec = genericLiftShowsPrec
+instance Eq1 EntityIdentifier where liftEq = genericLiftEq
+instance Ord1 EntityIdentifier where liftCompare = genericLiftCompare
+instance Show1 EntityIdentifier where liftShowsPrec = genericLiftShowsPrec
 
-instance Evaluatable TypeVariableIdentifier
+instance Evaluatable EntityIdentifier
 
-newtype TypeConstructorIdentifier a = TypeConstructorIdentifier { typeConstructorIdentifiername :: Name }
+data Operator a = VariableOperator a
+                | ConstructorOperator a
+                | TypeOperator Name
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
 
-instance Eq1 TypeConstructorIdentifier where liftEq = genericLiftEq
-instance Ord1 TypeConstructorIdentifier where liftCompare = genericLiftCompare
-instance Show1 TypeConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec
+instance Eq1 Operator where liftEq = genericLiftEq
+instance Ord1 Operator where liftCompare = genericLiftCompare
+instance Show1 Operator where liftShowsPrec = genericLiftShowsPrec
 
-instance Evaluatable TypeConstructorIdentifier
-
-newtype ModuleIdentifier a = ModuleIdentifier { moduleIdentifierName :: Name }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
-
-instance Eq1 ModuleIdentifier where liftEq = genericLiftEq
-instance Ord1 ModuleIdentifier where liftCompare = genericLiftCompare
-instance Show1 ModuleIdentifier where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable ModuleIdentifier
-
-newtype ConstructorIdentifier a = ConstructorIdentifier { constructorIdentifierName :: Name }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
-
-instance Eq1 ConstructorIdentifier where liftEq = genericLiftEq
-instance Ord1 ConstructorIdentifier where liftCompare = genericLiftCompare
-instance Show1 ConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable ConstructorIdentifier
-
-newtype TypeClassIdentifier a = TypeClassIdentifier { typeClassIdentifierName :: Name }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
-
-instance Eq1 TypeClassIdentifier where liftEq = genericLiftEq
-instance Ord1 TypeClassIdentifier where liftCompare = genericLiftCompare
-instance Show1 TypeClassIdentifier where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable TypeClassIdentifier
-
-newtype VariableIdentifier a = VariableIdentifier { variableIdentifierName :: Name }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
-
-instance Eq1 VariableIdentifier where liftEq = genericLiftEq
-instance Ord1 VariableIdentifier where liftCompare = genericLiftCompare
-instance Show1 VariableIdentifier where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable VariableIdentifier
-
-newtype PrimitiveConstructorIdentifier a = PrimitiveConstructorIdentifier { primitiveConstructorIdentifierName :: Name }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
-
-instance Eq1 PrimitiveConstructorIdentifier where liftEq = genericLiftEq
-instance Ord1 PrimitiveConstructorIdentifier where liftCompare = genericLiftCompare
-instance Show1 PrimitiveConstructorIdentifier where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable PrimitiveConstructorIdentifier
-
-newtype PrimitiveVariableIdentifier a = PrimitiveVariableIdentifier { primitiveVariableIdentifierName :: Name }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
-
-instance Eq1 PrimitiveVariableIdentifier where liftEq = genericLiftEq
-instance Ord1 PrimitiveVariableIdentifier where liftCompare = genericLiftCompare
-instance Show1 PrimitiveVariableIdentifier where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable PrimitiveVariableIdentifier
+instance Evaluatable Operator
 
 newtype ConstructorSymbol a = ConstructorSymbol { constructorSymbolName :: Name }
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
@@ -452,15 +389,6 @@ instance Show1 ConstructorSymbol where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable ConstructorSymbol
 
-newtype TypeOperator a = TypeOperator { typeOperatorName :: Name }
-  deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
-
-instance Eq1 TypeOperator where liftEq = genericLiftEq
-instance Ord1 TypeOperator where liftCompare = genericLiftCompare
-instance Show1 TypeOperator where liftShowsPrec = genericLiftShowsPrec
-
-instance Evaluatable TypeOperator
-
 newtype VariableSymbol a = VariableSymbol { variableSymbolName :: Name }
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
 

src/Rendering/Renderer.hs

@@ -18,6 +18,7 @@ module Rendering.Renderer
 , TOCSummary(..)
 , SymbolFields(..)
 , defaultSymbolFields
+, parseSymbolFields
 ) where
 
 import Data.Aeson (Value)

src/Rendering/Symbol.hs

@@ -4,6 +4,7 @@ module Rendering.Symbol
 , renderToTags
 , SymbolFields(..)
 , defaultSymbolFields
+, parseSymbolFields
 ) where
 
 import Prologue
@@ -13,6 +14,7 @@ import Data.Blob
 import Data.Language (ensureLanguage)
 import Data.Record
 import Data.Span
+import Data.List.Split (splitWhen)
 import Data.Term
 import qualified Data.Text as T
 import Rendering.TOC
@@ -100,3 +102,15 @@ defaultSymbolFields = SymbolFields True False False True False True
 
 defaultTagSymbolFields :: SymbolFields
 defaultTagSymbolFields = SymbolFields True True True True True True
+
+parseSymbolFields :: String -> SymbolFields
+parseSymbolFields arg =
+  let fields = splitWhen (== ',') arg in
+  SymbolFields
+    { symbolFieldsName = "symbol" `elem` fields
+    , symbolFieldsPath = "path" `elem` fields
+    , symbolFieldsLang = "language" `elem` fields
+    , symbolFieldsKind = "kind" `elem` fields
+    , symbolFieldsLine = "line" `elem` fields
+    , symbolFieldsSpan = "span" `elem` fields
+    }

src/Semantic/CLI.hs

@@ -115,13 +115,4 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
     findOption options value = maybe "" fst (find ((== value) . snd) options)
 
     -- Example: semantic parse --symbols --fields=symbol,path,language,kind,line,span
-    symbolFieldsReader = eitherReader parseSymbolFields
-    parseSymbolFields arg = let fields = splitWhen (== ',') arg in
-                      Right SymbolFields
-                        { symbolFieldsName = "symbol" `elem` fields
-                        , symbolFieldsPath = "path" `elem` fields
-                        , symbolFieldsLang = "language" `elem` fields
-                        , symbolFieldsKind = "kind" `elem` fields
-                        , symbolFieldsLine = "line" `elem` fields
-                        , symbolFieldsSpan = "span" `elem` fields
-                        }
+    symbolFieldsReader = eitherReader (Right . parseSymbolFields)

src/Semantic/Env.hs

@@ -0,0 +1,15 @@
+module Semantic.Env where
+
+import Control.Monad.IO.Class
+import Prologue
+import System.Environment
+import Text.Read (readMaybe)
+
+envLookupHost :: MonadIO io => String -> String -> io String
+envLookupHost defaultHost k = liftIO $ fromMaybe defaultHost <$> lookupEnv k
+
+envLookupPort :: MonadIO io => Int -> String -> io Int
+envLookupPort defaultPort k = liftIO $ parsePort <$> lookupEnv k
+  where parsePort x | Just s <- x
+                    , Just p <- readMaybe s = p
+                    | otherwise = defaultPort

src/Semantic/IO.hs

@@ -20,6 +20,8 @@ module Semantic.IO
 , readBlobs
 , readBlobsFromDir
 , readBlobsFromHandle
+, decodeBlobPairs
+, decodeBlobs
 , readFile
 , readFilePair
 , readProject
@@ -37,14 +39,14 @@ import           Control.Monad.Effect
 import           Control.Monad.Effect.Exception
 import           Control.Monad.IO.Class
 import           Data.Aeson
-import qualified Data.Blob as Blob
+import           Data.Blob
 import           Data.Bool
 import           Data.Project
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Builder as B
 import qualified Data.ByteString.Lazy as BL
 import           Data.Language
-import           Data.Source (fromUTF8, fromText)
+import           Data.Source (fromUTF8)
 import           Prelude hiding (readFile)
 import           Prologue hiding (MonadError (..), fail)
 import           System.Directory (doesDirectoryExist)
@@ -54,16 +56,15 @@ import           System.Exit
 import           System.FilePath
 import           System.FilePath.Glob
 import qualified System.IO as IO
-import           Text.Read
 
 -- | Read a utf8-encoded file to a 'Blob'.
-readFile :: forall m. MonadIO m => File -> m (Maybe Blob.Blob)
+readFile :: forall m. MonadIO m => File -> m (Maybe Blob)
 readFile (File "/dev/null" _) = pure Nothing
 readFile (File path language) = do
-  raw <- liftIO (Just <$> B.readFile path)
-  pure $ Blob.sourceBlob path language . fromUTF8 <$> raw
+  raw <- liftIO $ B.readFile path
+  pure . Just . sourceBlob path language . fromUTF8 $ raw
 
-readFilePair :: forall m. MonadIO m => File -> File -> m Blob.BlobPair
+readFilePair :: forall m. MonadIO m => File -> File -> m BlobPair
 readFilePair a b = Join <$> join (maybeThese <$> readFile a <*> readFile b)
 
 maybeThese :: Monad m => Maybe a -> Maybe b -> m (These a b)
@@ -73,27 +74,27 @@ maybeThese a b = case (a, b) of
   (Just a, Just b)  -> pure (These a b)
   _                 -> fail "expected file pair with content on at least one side"
 
+newtype Blobs a = Blobs { blobs :: [a] }
+  deriving (Generic, FromJSON)
+
 isDirectory :: MonadIO m => FilePath -> m Bool
 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 -> Language
-languageForFilePath = languageForType . takeExtension
+decodeBlobPairs :: BL.ByteString -> Either String [BlobPair]
+decodeBlobPairs = fmap blobs <$> eitherDecode
 
 -- | Read JSON encoded blob pairs from a handle.
-readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob.BlobPair]
-readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle
-  where
-    toBlobPairs :: BlobDiff -> [Blob.BlobPair]
-    toBlobPairs BlobDiff{..} = toBlobPair <$> blobs
-    toBlobPair blobs = toBlob <$> blobs
+readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
+readBlobPairsFromHandle = fmap blobs <$> readFromHandle
+
+decodeBlobs :: BL.ByteString -> Either String [Blob]
+decodeBlobs = fmap blobs <$> eitherDecode
 
 -- | Read JSON encoded blobs from a handle.
-readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob.Blob]
-readBlobsFromHandle = fmap toBlobs . readFromHandle
-  where toBlobs BlobParse{..} = fmap toBlob blobs
+readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob]
+readBlobsFromHandle = fmap blobs <$> readFromHandle
 
-readBlobFromPath :: MonadIO m => File -> m Blob.Blob
+readBlobFromPath :: MonadIO m => File -> m Blob
 readBlobFromPath file = do
   maybeFile <- readFile file
   maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
@@ -135,7 +136,7 @@ findFilesInDir path exts excludeDirs = do
       | otherwise = True
     notIn _ _ = True
 
-readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
+readBlobsFromDir :: MonadIO m => FilePath -> m [Blob]
 readBlobsFromDir path = do
   paths <- liftIO (globDir1 (compile "[^vendor]**/*[.rb|.js|.tsx|.go|.py]") path)
   let paths' = fmap (\p -> File p (languageForFilePath p)) paths
@@ -149,38 +150,6 @@ readFromHandle (ReadHandle h) = do
     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
-          _  -> fromMaybe Unknown (readMaybe language)
-
-
-newtype BlobDiff = BlobDiff { blobs :: [BlobPair] }
-  deriving (Show, Generic, FromJSON)
-
-newtype BlobParse = BlobParse { blobs :: [Blob] }
-  deriving (Show, Generic, FromJSON)
-
-type BlobPair = Join These Blob
-
-data Blob = Blob
-  { path     :: FilePath
-  , content  :: Text
-  , language :: String
-  }
-  deriving (Show, Generic, FromJSON)
-
-instance FromJSON BlobPair where
-  parseJSON = withObject "BlobPair" $ \o -> do
-    before <- o .:? "before"
-    after <- o .:? "after"
-    case (before, after) of
-      (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"
-
 
 -- | An exception indicating that we’ve tried to diff or parse a blob of unknown language.
 newtype NoLanguageForBlob = NoLanguageForBlob FilePath
@@ -190,16 +159,16 @@ noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a
 noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
 
 
-readBlob :: Member Files effs => File -> Eff effs Blob.Blob
+readBlob :: Member Files effs => File -> Eff effs Blob
 readBlob = send . Read . FromPath
 
 -- | 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 'IO.ReadMode) [File] -> Eff effs [Blob.Blob]
+readBlobs :: Member Files effs => Either (Handle 'IO.ReadMode) [File] -> Eff effs [Blob]
 readBlobs (Left handle) = send (Read (FromHandle handle))
 readBlobs (Right paths) = traverse (send . Read . FromPath) paths
 
 -- | 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 'IO.ReadMode) [Both File] -> Eff effs [Blob.BlobPair]
+readBlobPairs :: Member Files effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [BlobPair]
 readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
 readBlobPairs (Right paths) = traverse (send . Read . FromPathPair) paths
 
@@ -237,14 +206,14 @@ openFileForReading :: FilePath -> IO (Handle 'IO.ReadMode)
 openFileForReading path = ReadHandle <$> IO.openFile path IO.ReadMode
 
 data Source blob where
-  FromPath       :: File                -> Source Blob.Blob
-  FromHandle     :: Handle 'IO.ReadMode -> Source [Blob.Blob]
-  FromPathPair   :: Both File           -> Source Blob.BlobPair
-  FromPairHandle :: Handle 'IO.ReadMode -> Source [Blob.BlobPair]
+  FromPath       :: File                -> Source Blob
+  FromHandle     :: Handle 'IO.ReadMode -> Source [Blob]
+  FromPathPair   :: Both File           -> Source BlobPair
+  FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair]
 
 data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
 
--- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's.
+-- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
 data Files out where
   Read        :: Source out -> Files out
   ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project

src/Semantic/Task.hs

@@ -38,6 +38,7 @@ module Semantic.Task
 -- * Interpreting
 , runTask
 , runTaskWithOptions
+, runTaskWithOptions'
 -- * Re-exports
 , Distribute
 , Eff
@@ -135,6 +136,15 @@ runTaskWithOptions options task = do
   statter <- defaultStatsClient >>= newQueue sendStat
   logger <- newQueue logMessage options
 
+  result <- runTaskWithOptions' options logger statter task
+
+  closeQueue statter
+  closeStatClient (asyncQueueExtra statter)
+  closeQueue logger
+  either (die . displayException) pure result
+
+runTaskWithOptions' :: Options -> AsyncQueue Message Options -> AsyncQueue Stat StatsClient -> TaskEff a -> IO (Either SomeException a)
+runTaskWithOptions' options logger statter task = do
   (result, stat) <- withTiming "run" [] $ do
     let run :: TaskEff a -> IO (Either SomeException a)
         run = runM . runError
@@ -147,11 +157,7 @@ runTaskWithOptions options task = do
                    . runDistribute (run . unwrapTask)
     run task
   queue statter stat
-
-  closeQueue statter
-  closeStatClient (asyncQueueExtra statter)
-  closeQueue logger
-  either (die . displayException) pure result
+  pure result
 
 runTraceInTelemetry :: Member Telemetry effects => Eff (Trace ': effects) a -> Eff effects a
 runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])

test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffA-B.txt

@@ -62,9 +62,6 @@
       ->(TypeConstructorIdentifier) }
         (TypeParameters)
         (Empty))
-    {+(Constructor
-      {+(ConstructorIdentifier)+}
-      {+(TypeParameters)+})+}
       (Constructor
       { (ConstructorIdentifier)
       ->(ConstructorIdentifier) }
@@ -72,6 +69,12 @@
     {+(Constructor
       {+(ConstructorIdentifier)+}
       {+(TypeParameters)+})+}
+    {+(Constructor
+      {+(ConstructorIdentifier)+}
+      {+(TypeParameters)+})+}
+    {+(Constructor
+      {+(ConstructorIdentifier)+}
+      {+(TypeParameters)+})+}
     {+(Constructor
       {+(ConstructorIdentifier)+}
       {+(TypeParameters)+})+}
@@ -79,9 +82,6 @@
       { (ConstructorIdentifier)
       ->(ConstructorIdentifier) }
         (TypeParameters))
-    {+(Constructor
-      {+(ConstructorIdentifier)+}
-      {+(TypeParameters)+})+}
     {-(Constructor
       {-(ConstructorIdentifier)-}
       {-(TypeParameters)-})-}

test/fixtures/haskell/corpus/algebraic-datatype-declarations.diffB-A.txt

@@ -62,6 +62,10 @@
       ->(TypeConstructorIdentifier) }
         (TypeParameters)
         (Empty))
+      (Constructor
+      { (ConstructorIdentifier)
+      ->(ConstructorIdentifier) }
+        (TypeParameters))
     {+(Constructor
       {+(ConstructorIdentifier)+}
       {+(TypeParameters)+})+}
@@ -78,12 +82,6 @@
     {+(Constructor
       {+(ConstructorIdentifier)+}
       {+(TypeParameters)+})+}
-    {+(Constructor
-      {+(ConstructorIdentifier)+}
-      {+(TypeParameters)+})+}
-    {-(Constructor
-      {-(ConstructorIdentifier)-}
-      {-(TypeParameters)-})-}
     {-(Constructor
       {-(ConstructorIdentifier)-}
       {-(TypeParameters)-})-}