module Language.PureScript.Ide.Imports
( addImplicitImport
, addImportForIdentifier
, answerRequest
, parseImport
, prettyPrintImportSection
, addImplicitImport'
, addExplicitImport'
, sliceImportSection
, prettyPrintImport'
, Import(Import)
)
where
import Protolude
import Control.Lens ((^.))
import Data.List (findIndex, nubBy)
import qualified Data.Text as T
import qualified Language.PureScript as P
import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Filter
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import System.IO.UTF8 (writeUTF8FileT)
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 IdeError m) =>
FilePath -> m (P.ModuleName, [Text], [Import], [Text])
parseImportsFromFile fp = do
file <- ideReadFile fp
case sliceImportSection (T.lines file) of
Right res -> pure res
Left err -> throwError (GeneralError err)
parseImportsWithModuleName :: [Text] -> Either Text (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 Text (P.ModuleName, [Text], [Import], [Text])
sliceImportSection ts =
case foldl step (ModuleHeader 0) (zip [0..] ts) of
Res start end ->
let
(moduleHeader, (importSection, remainingFile)) =
splitAt (succ (end start)) `second` splitAt start ts
in
(\(mn, is) -> (mn, moduleHeader, is, remainingFile)) <$>
parseImportsWithModuleName (moduleHeader <> importSection)
ModuleHeader ix ->
let (moduleHeader, remainingFile) = 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 Text P.Module
moduleParse t = first show $ do
tokens <- P.lex "" (T.unlines t)
P.runTokenParser "<psc-ide>" P.parseModule tokens
addImplicitImport :: (MonadIO m, MonadError IdeError 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 IdeError m) =>
FilePath -> IdeDeclaration -> 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' :: IdeDeclaration -> 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 (IdeDeclTypeClass tc) =
P.TypeClassRef (tc ^. ideTCName)
refFromDeclaration (IdeDeclDataConstructor dtor) =
P.TypeRef (dtor ^. ideDtorTypeName) Nothing
refFromDeclaration (IdeDeclType t) =
P.TypeRef (t ^. ideTypeName) (Just [])
refFromDeclaration (IdeDeclValueOperator op) =
P.ValueOpRef (op ^. ideValueOpName)
refFromDeclaration (IdeDeclTypeOperator op) =
P.TypeOpRef (op ^. ideTypeOpName)
refFromDeclaration d =
P.ValueRef (P.Ident (identifierFromIdeDeclaration d))
insertDeclIntoImport :: IdeDeclaration -> Import -> Import
insertDeclIntoImport decl' (Import mn (P.Explicit refs) Nothing) =
Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) Nothing
insertDeclIntoImport _ is = is
insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef]
insertDeclIntoRefs d@(IdeDeclDataConstructor dtor) refs =
updateAtFirstOrPrepend
(matchType (dtor ^. ideDtorTypeName))
(insertDtor (dtor ^. ideDtorName))
(refFromDeclaration d)
refs
insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs)
insertDtor _ (P.TypeRef tn' _) = 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 findIndex p l of
Nothing -> d : l
Just ix ->
let (x, a : y) = splitAt ix l
in x ++ [t a] ++ y
addImportForIdentifier :: (Ide m, MonadError IdeError m)
=> FilePath
-> Text
-> [Filter]
-> m (Either [Match IdeDeclaration] [Text])
addImportForIdentifier fp ident filters = do
modules <- getAllModules Nothing
case map (fmap discardAnn) (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 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 m1
Nothing ->
throwError (GeneralError "Undecidable between type and dataconstructor")
xs ->
pure $ Left xs
where
decideRedundantCase d@(IdeDeclDataConstructor dtor) (IdeDeclType t) =
if dtor ^. ideDtorTypeName == t ^. ideTypeName then Just d else Nothing
decideRedundantCase IdeDeclType{} ts@IdeDeclTypeSynonym{} =
Just ts
decideRedundantCase _ _ = Nothing
prettyPrintImport' :: Import -> Text
prettyPrintImport' (Import mn (P.Explicit refs) qual) =
"import " <> P.prettyPrintImport mn (P.Explicit (unwrapPositionedRef <$> refs)) qual
prettyPrintImport' (Import mn idt qual) =
"import " <> P.prettyPrintImport mn idt qual
prettyPrintImportSection :: [Import] -> [Text]
prettyPrintImportSection imports = map prettyPrintImport' (sort imports)
answerRequest :: (MonadIO m) => Maybe FilePath -> [Text] -> m Success
answerRequest outfp rs =
case outfp of
Nothing -> pure (MultilineTextResult rs)
Just outfp' -> do
liftIO (writeUTF8FileT outfp' (T.unlines rs))
pure (TextResult ("Written to " <> T.pack outfp'))
parseImport :: Text -> Maybe Import
parseImport t =
case P.lex "<psc-ide>" 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