Merge branch 'master' into haskell-assignment

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/Semantic/IO.hs

@@ -39,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)
@@ -56,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)
@@ -75,35 +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 [Blob.BlobPair]
-decodeBlobPairs = fmap toBlobPairs . eitherDecode
+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
+readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [BlobPair]
+readBlobPairsFromHandle = fmap blobs <$> readFromHandle
 
-toBlobPairs :: BlobDiff -> [Blob.BlobPair]
-toBlobPairs BlobDiff{..} = toBlobPair <$> blobs
-  where toBlobPair blobs = toBlob <$> blobs
-
-decodeBlobs :: BL.ByteString -> Either String [Blob.Blob]
-decodeBlobs = fmap toBlobs . eitherDecode
+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
+readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob]
+readBlobsFromHandle = fmap blobs <$> readFromHandle
 
-toBlobs :: BlobParse -> [Blob.Blob]
-toBlobs BlobParse{..} = fmap toBlob blobs
-
-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
@@ -145,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
@@ -159,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
@@ -200,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
 
@@ -247,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