module Language.PureScript.Ide.Imports
( addImplicitImport
, addImportForIdentifier
, answerRequest
, parseImport
, prettyPrintImportSection
, addImplicitImport'
, addExplicitImport'
, sliceImportSection
, prettyPrintImport'
, Import(Import)
)
where
import Prelude.Compat
import Control.Applicative ((<|>))
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import "monad-logger" Control.Monad.Logger
import Data.Bifunctor (first, second)
import Data.Function (on)
import qualified Data.List as List
import Data.Maybe (isNothing)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Language.PureScript as P
import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Externs (unwrapPositioned,
unwrapPositionedRef)
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
deriving (Eq, Show)
instance Ord Import where
compare = compImport
compImportType :: P.ImportDeclarationType -> P.ImportDeclarationType -> Ordering
compImportType P.Implicit P.Implicit = EQ
compImportType P.Implicit _ = LT
compImportType (P.Explicit _) (P.Hiding _) = LT
compImportType (P.Explicit _) (P.Explicit _) = EQ
compImportType (P.Explicit _) P.Implicit = GT
compImportType (P.Hiding _) (P.Hiding _) = EQ
compImportType (P.Hiding _) _ = GT
compImport :: Import -> Import -> Ordering
compImport (Import n i q) (Import n' i' q')
| compImportType i i' /= EQ = compImportType i i'
| not (P.isExplicit i) && isNothing q = LT
| not (P.isExplicit i) && isNothing q' = GT
| otherwise = compare n n'
parseImportsFromFile :: (MonadIO m, MonadError PscIdeError m) =>
FilePath -> m (P.ModuleName, [Text], [Import], [Text])
parseImportsFromFile fp = do
file <- liftIO (TIO.readFile fp)
case sliceImportSection (T.lines file) of
Right res -> pure res
Left err -> throwError (GeneralError err)
parseImportsWithModuleName :: [Text] -> Either String (P.ModuleName, [Import])
parseImportsWithModuleName ls = do
(P.Module _ _ mn decls _) <- moduleParse ls
pure (mn, concatMap mkImport (unwrapPositioned <$> decls))
where
mkImport (P.ImportDeclaration mn (P.Explicit refs) qual) =
[Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual]
mkImport (P.ImportDeclaration mn it qual) = [Import mn it qual]
mkImport _ = []
sliceImportSection :: [Text] -> Either String (P.ModuleName, [Text], [Import], [Text])
sliceImportSection ts =
case foldl step (ModuleHeader 0) (zip [0..] ts) of
Res start end ->
let
(moduleHeader, (importSection, remainingFile)) =
List.splitAt (succ (end start)) `second` List.splitAt start ts
in
(\(mn, is) -> (mn, moduleHeader, is, remainingFile)) <$>
parseImportsWithModuleName (moduleHeader <> importSection)
ModuleHeader ix ->
let (moduleHeader, remainingFile) = List.splitAt (succ ix) ts
in
(\(mn, is) -> (mn, moduleHeader ++ [""], is, remainingFile)) <$>
parseImportsWithModuleName moduleHeader
_ -> Left "Failed to detect the import section"
data ImportStateMachine = ModuleHeader Int | ImportSection Int Int | Res Int Int
step :: ImportStateMachine -> (Int, Text) -> ImportStateMachine
step (ModuleHeader mi) (ix, l)
| T.isPrefixOf "module " l = ModuleHeader ix
| T.isPrefixOf "import " l = ImportSection ix ix
| otherwise = ModuleHeader mi
step (ImportSection start lastImportLine) (ix, l)
| any (`T.isPrefixOf` l) ["import", " "] = ImportSection start ix
| T.isPrefixOf "--" l || l == "" = ImportSection start lastImportLine
| otherwise = Res start lastImportLine
step (Res start end) _ = Res start end
moduleParse :: [Text] -> Either String P.Module
moduleParse t = first show $ do
tokens <- (P.lex "" . T.unpack . T.unlines) t
P.runTokenParser "<psc-ide>" P.parseModule tokens
addImplicitImport :: (MonadIO m, MonadError PscIdeError m)
=> FilePath
-> P.ModuleName
-> m [Text]
addImplicitImport fp mn = do
(_, pre, imports, post) <- parseImportsFromFile fp
let newImportSection = addImplicitImport' imports mn
pure $ pre ++ newImportSection ++ post
addImplicitImport' :: [Import] -> P.ModuleName -> [Text]
addImplicitImport' imports mn =
prettyPrintImportSection ( imports ++ [Import mn P.Implicit Nothing])
addExplicitImport :: (MonadIO m, MonadError PscIdeError m, MonadLogger m) =>
FilePath -> ExternDecl -> P.ModuleName -> m [Text]
addExplicitImport fp decl moduleName = do
(mn, pre, imports, post) <- parseImportsFromFile fp
let newImportSection =
if mn == moduleName
then imports
else addExplicitImport' decl moduleName imports
pure (pre ++ prettyPrintImportSection newImportSection ++ post)
addExplicitImport' :: ExternDecl -> P.ModuleName -> [Import] -> [Import]
addExplicitImport' decl moduleName imports =
let
isImplicitlyImported =
not . null $ filter (\case
(Import mn P.Implicit Nothing) -> mn == moduleName
_ -> False) imports
matches (Import mn (P.Explicit _) Nothing) = mn == moduleName
matches _ = False
freshImport = Import moduleName (P.Explicit [refFromDeclaration decl]) Nothing
in
if isImplicitlyImported
then imports
else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports
where
refFromDeclaration (TypeClassDeclaration n) =
P.TypeClassRef n
refFromDeclaration (DataConstructor n tn _) =
P.TypeRef tn (Just [P.ProperName (T.unpack n)])
refFromDeclaration (TypeDeclaration n _) =
P.TypeRef n (Just [])
refFromDeclaration (ValueOperator op _ _ _) =
P.ValueOpRef op
refFromDeclaration (TypeOperator op _ _ _) =
P.TypeOpRef op
refFromDeclaration d =
P.ValueRef $ P.Ident $ T.unpack (identifierFromExternDecl d)
insertDeclIntoImport :: ExternDecl -> Import -> Import
insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =
Import mn (P.Explicit (insertDeclIntoRefs decl' refs)) Nothing
insertDeclIntoImport _ is = is
insertDeclIntoRefs :: ExternDecl -> [P.DeclarationRef] -> [P.DeclarationRef]
insertDeclIntoRefs (DataConstructor dtor tn _) refs =
let
dtor' = P.ProperName (T.unpack dtor)
in
updateAtFirstOrPrepend (matchType tn) (insertDtor dtor') (P.TypeRef tn (Just [dtor'])) refs
insertDeclIntoRefs dr refs = List.nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)
insertDtor dtor (P.TypeRef tn' dtors) =
case dtors of
Just dtors' -> P.TypeRef tn' (Just (List.nub (dtor : dtors')))
Nothing -> P.TypeRef tn' Nothing
insertDtor _ refs = refs
matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool
matchType tn (P.TypeRef n _) = tn == n
matchType _ _ = False
updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a]
updateAtFirstOrPrepend p t d l =
case List.findIndex p l of
Nothing -> d : l
Just ix ->
let (x, a : y) = List.splitAt ix l
in x ++ [t a] ++ y
addImportForIdentifier :: (PscIde m, MonadError PscIdeError m, MonadLogger m)
=> FilePath
-> Text
-> [Filter]
-> m (Either [Match] [Text])
addImportForIdentifier fp ident filters = do
modules <- getAllModulesWithReexports
case getExactMatches ident filters modules of
[] ->
throwError (NotFound "Couldn't find the given identifier. \
\Have you loaded the corresponding module?")
[Match m decl] ->
Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m))
ms@[Match m1 d1, Match m2 d2] ->
if m1 /= m2
then pure $ Left ms
else case decideRedundantCase d1 d2 <|> decideRedundantCase d2 d1 of
Just decl ->
Right <$> addExplicitImport fp decl (P.moduleNameFromString (T.unpack m1))
Nothing ->
throwError (GeneralError "Undecidable between type and dataconstructor")
xs ->
pure $ Left xs
where
decideRedundantCase dtor@(DataConstructor _ t _) (TypeDeclaration t' _) =
if t == t' then Just dtor else Nothing
decideRedundantCase TypeDeclaration{} ts@TypeSynonymDeclaration{} =
Just ts
decideRedundantCase _ _ = Nothing
prettyPrintImport' :: Import -> Text
prettyPrintImport' (Import mn (P.Explicit refs) qual) =
T.pack $ "import " ++ P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual
prettyPrintImport' (Import mn idt qual) =
T.pack $ "import " ++ P.prettyPrintImport mn idt qual
prettyPrintImportSection :: [Import] -> [Text]
prettyPrintImportSection imports = map prettyPrintImport' (List.sort imports)
answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success
answerRequest outfp rs =
case outfp of
Nothing -> pure $ MultilineTextResult rs
Just outfp' -> do
liftIO $ TIO.writeFile outfp' (T.unlines rs)
pure $ TextResult $ "Written to " <> T.pack outfp'
parseImport :: Text -> Maybe Import
parseImport t =
case P.lex "<psc-ide>" (T.unpack t)
>>= P.runTokenParser "<psc-ide>" P.parseImportDeclaration' of
Right (mn, P.Explicit refs, mmn) ->
Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn)
Right (mn, idt, mmn) -> Just (Import mn idt mmn)
Left _ -> Nothing