-----------------------------------------------------------------------------
--
-- Module      : Language.PureScript.Ide.Util
-- Description : Generally useful functions and conversions
-- Copyright   : Christoph Hegemann 2016
-- License     : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer  : Christoph Hegemann <christoph.hegemann1337@gmail.com>
-- Stability   : experimental
--
-- |
-- Generally useful functions
-----------------------------------------------------------------------------

module Language.PureScript.Ide.Util
  ( identifierFromIdeDeclaration
  , unwrapMatch
  , namespaceForDeclaration
  , encodeT
  , decodeT
  , discardAnn
  , withEmptyAnn
  , valueOperatorAliasT
  , typeOperatorAliasT
  , properNameT
  , identT
  , opNameT
  , ideReadFile
  , module Language.PureScript.Ide.Logging
  ) where

import           Protolude                           hiding (decodeUtf8,
                                                      encodeUtf8, to)

import           Control.Lens                        hiding (op, (&))
import           Data.Aeson
import qualified Data.Text                           as T
import qualified Data.Text.Lazy                      as TL
import           Data.Text.Lazy.Encoding             as TLE
import qualified Language.PureScript                 as P
import           Language.PureScript.Ide.Error       (IdeError(..))
import           Language.PureScript.Ide.Logging
import           Language.PureScript.Ide.Types
import           System.IO.UTF8                      (readUTF8FileT)
import           System.Directory                    (makeAbsolute)

identifierFromIdeDeclaration :: IdeDeclaration -> Text
identifierFromIdeDeclaration :: IdeDeclaration -> Text
identifierFromIdeDeclaration IdeDeclaration
d = case IdeDeclaration
d of
  IdeDeclValue IdeValue
v -> IdeValue
v forall s a. s -> Getting a s a -> a
^. Lens' IdeValue Ident
ideValueIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. Getting r Ident Text
identT
  IdeDeclType IdeType
t -> IdeType
t forall s a. s -> Getting a s a -> a
^. Lens' IdeType (ProperName 'TypeName)
ideTypeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (a :: ProperNameType). Getting r (ProperName a) Text
properNameT
  IdeDeclTypeSynonym IdeTypeSynonym
s -> IdeTypeSynonym
s forall s a. s -> Getting a s a -> a
^. Lens' IdeTypeSynonym (ProperName 'TypeName)
ideSynonymName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (a :: ProperNameType). Getting r (ProperName a) Text
properNameT
  IdeDeclDataConstructor IdeDataConstructor
dtor -> IdeDataConstructor
dtor forall s a. s -> Getting a s a -> a
^. Lens' IdeDataConstructor (ProperName 'ConstructorName)
ideDtorName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (a :: ProperNameType). Getting r (ProperName a) Text
properNameT
  IdeDeclTypeClass IdeTypeClass
tc -> IdeTypeClass
tc forall s a. s -> Getting a s a -> a
^. Lens' IdeTypeClass (ProperName 'ClassName)
ideTCName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (a :: ProperNameType). Getting r (ProperName a) Text
properNameT
  IdeDeclValueOperator IdeValueOperator
op -> IdeValueOperator
op forall s a. s -> Getting a s a -> a
^. Lens' IdeValueOperator (OpName 'ValueOpName)
ideValueOpName forall a b. a -> (a -> b) -> b
& forall (a :: OpNameType). OpName a -> Text
P.runOpName
  IdeDeclTypeOperator IdeTypeOperator
op -> IdeTypeOperator
op forall s a. s -> Getting a s a -> a
^. Lens' IdeTypeOperator (OpName 'TypeOpName)
ideTypeOpName forall a b. a -> (a -> b) -> b
& forall (a :: OpNameType). OpName a -> Text
P.runOpName
  IdeDeclModule ModuleName
name -> ModuleName -> Text
P.runModuleName ModuleName
name

namespaceForDeclaration :: IdeDeclaration -> IdeNamespace
namespaceForDeclaration :: IdeDeclaration -> IdeNamespace
namespaceForDeclaration IdeDeclaration
d = case IdeDeclaration
d of
  IdeDeclValue IdeValue
_ -> IdeNamespace
IdeNSValue
  IdeDeclType IdeType
_ -> IdeNamespace
IdeNSType
  IdeDeclTypeSynonym IdeTypeSynonym
_ -> IdeNamespace
IdeNSType
  IdeDeclDataConstructor IdeDataConstructor
_ -> IdeNamespace
IdeNSValue
  IdeDeclTypeClass IdeTypeClass
_ -> IdeNamespace
IdeNSType
  IdeDeclValueOperator IdeValueOperator
_ -> IdeNamespace
IdeNSValue
  IdeDeclTypeOperator IdeTypeOperator
_ -> IdeNamespace
IdeNSType
  IdeDeclModule ModuleName
_ -> IdeNamespace
IdeNSModule

discardAnn :: IdeDeclarationAnn -> IdeDeclaration
discardAnn :: IdeDeclarationAnn -> IdeDeclaration
discardAnn (IdeDeclarationAnn Annotation
_ IdeDeclaration
d) = IdeDeclaration
d

withEmptyAnn :: IdeDeclaration -> IdeDeclarationAnn
withEmptyAnn :: IdeDeclaration -> IdeDeclarationAnn
withEmptyAnn = Annotation -> IdeDeclaration -> IdeDeclarationAnn
IdeDeclarationAnn Annotation
emptyAnn

unwrapMatch :: Match a -> a
unwrapMatch :: forall a. Match a -> a
unwrapMatch (Match (ModuleName
_, a
ed)) = a
ed

valueOperatorAliasT
  :: P.Qualified (Either P.Ident (P.ProperName 'P.ConstructorName)) -> Text
valueOperatorAliasT :: Qualified (Either Ident (ProperName 'ConstructorName)) -> Text
valueOperatorAliasT =
  forall a. (a -> Text) -> Qualified a -> Text
P.showQualified forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Ident -> Text
P.runIdent forall (a :: ProperNameType). ProperName a -> Text
P.runProperName

typeOperatorAliasT
  :: P.Qualified (P.ProperName 'P.TypeName) -> Text
typeOperatorAliasT :: Qualified (ProperName 'TypeName) -> Text
typeOperatorAliasT =
  forall a. (a -> Text) -> Qualified a -> Text
P.showQualified forall (a :: ProperNameType). ProperName a -> Text
P.runProperName

encodeT :: (ToJSON a) => a -> Text
encodeT :: forall a. ToJSON a => a -> Text
encodeT = Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TLE.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode

decodeT :: (FromJSON a) => Text -> Either Text a
decodeT :: forall a. FromJSON a => Text -> Either Text a
decodeT = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
eitherDecode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TLE.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict

properNameT :: Getting r (P.ProperName a) Text
properNameT :: forall r (a :: ProperNameType). Getting r (ProperName a) Text
properNameT = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall (a :: ProperNameType). ProperName a -> Text
P.runProperName

identT :: Getting r P.Ident Text
identT :: forall r. Getting r Ident Text
identT = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Ident -> Text
P.runIdent

opNameT :: Getting r (P.OpName a) Text
opNameT :: forall r (a :: OpNameType). Getting r (OpName a) Text
opNameT = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall (a :: OpNameType). OpName a -> Text
P.runOpName

ideReadFile'
  :: (MonadIO m, MonadError IdeError m)
  => (FilePath -> IO Text)
  -> FilePath
  -> m (FilePath, Text)
ideReadFile' :: forall (m :: * -> *).
(MonadIO m, MonadError IdeError m) =>
(String -> IO Text) -> String -> m (String, Text)
ideReadFile' String -> IO Text
fileReader String
fp = do
  String
absPath <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO String
makeAbsolute String
fp)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (IOException
err :: IOException) ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (Text -> IdeError
GeneralError
          (Text
"Couldn't resolve path for: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show String
fp forall a. Semigroup a => a -> a -> a
<> Text
", Error: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show IOException
err))
    Right String
absPath -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
absPath
  Text
contents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => IO a -> IO (Either e a)
try (String -> IO Text
fileReader String
absPath)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (IOException
err :: IOException) ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (Text -> IdeError
GeneralError
          (Text
"Couldn't find file at: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show String
absPath forall a. Semigroup a => a -> a -> a
<> Text
", Error: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show IOException
err))
    Right Text
contents ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
contents
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
absPath, Text
contents)

ideReadFile :: (MonadIO m, MonadError IdeError m) => FilePath -> m (FilePath, Text)
ideReadFile :: forall (m :: * -> *).
(MonadIO m, MonadError IdeError m) =>
String -> m (String, Text)
ideReadFile = forall (m :: * -> *).
(MonadIO m, MonadError IdeError m) =>
(String -> IO Text) -> String -> m (String, Text)
ideReadFile' String -> IO Text
readUTF8FileT