1
1
mirror of https://github.com/github/semantic.git synced 2024-12-23 06:41:45 +03:00
semantic/src/Files.hs
2017-08-11 09:57:03 -04:00

92 lines
3.1 KiB
Haskell

{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables #-}
module Files
( readFile
, readBlobPairsFromHandle
, readBlobsFromHandle
, languageForFilePath
) where
import Control.Exception (catch, IOException)
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.Blob as Blob
import Data.Functor.Both
import Data.Maybe
import Data.Semigroup
import Data.Source
import Data.String
import Data.Text
import Data.These
import GHC.Generics
import Language
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 Text.Read
-- | Read a utf8-encoded file to a 'Blob'.
readFile :: forall m. MonadIO m => FilePath -> Maybe Language -> m Blob.Blob
readFile path@"/dev/null" _ = pure (Blob.emptyBlob path)
readFile path language = do
raw <- liftIO $ (Just <$> B.readFile path) `catch` (const (pure Nothing) :: IOException -> IO (Maybe B.ByteString))
pure $ fromMaybe (Blob.emptyBlob path) (Blob.sourceBlob path language . fromBytes <$> raw)
-- | Return a language based on a FilePath's extension, or Nothing if extension is not found or not supported.
languageForFilePath :: FilePath -> Maybe Language
languageForFilePath = languageForType . takeExtension
-- | Read JSON encoded blob pairs from a handle.
readBlobPairsFromHandle :: MonadIO m => Handle -> m [Both Blob.Blob]
readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle
where
toBlobPairs BlobDiff{..} = toBlobPair <$> blobs
toBlobPair blobs = Join (fromThese empty empty (runJoin (toBlob <$> blobs)))
where empty = Blob.emptyBlob (mergeThese const (runJoin (path <$> blobs)))
-- | Read JSON encoded blobs from a handle.
readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob]
readBlobsFromHandle = fmap toBlobs . readFromHandle
where toBlobs BlobParse{..} = fmap toBlob blobs
readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a
readFromHandle h = do
input <- liftIO $ BL.hGetContents h
case decode input of
Just d -> pure d
Nothing -> liftIO $ die ("invalid input on " <> show h <> ", expecting JSON")
toBlob :: Blob -> Blob.Blob
toBlob Blob{..} = Blob.sourceBlob path language' (fromText content)
where language' = case language of
"" -> languageForFilePath path
_ -> 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"