Skip to content

Commit

Permalink
Merge pull request #71 from fwcd/record-dot
Browse files Browse the repository at this point in the history
Migrate to record dot syntax
  • Loading branch information
fwcd authored Jul 27, 2024
2 parents eec924a + d271bc3 commit 0abe995
Show file tree
Hide file tree
Showing 13 changed files with 162 additions and 157 deletions.
28 changes: 14 additions & 14 deletions src/Curry/LanguageServer/Compiler.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE LambdaCase, OverloadedStrings, FlexibleContexts #-}
{-# LANGUAGE LambdaCase, NoFieldSelectors, OverloadedStrings, OverloadedRecordDot, FlexibleContexts #-}
module Curry.LanguageServer.Compiler
( CompileAuxiliary (..)
, CompileState (..)
Expand Down Expand Up @@ -63,20 +63,20 @@ newtype CompileAuxiliary = CompileAuxiliary

-- | Read/write state used during compilation.
data CompileState = CompileState
{ csWarnings :: [CM.Message]
, csErrors :: [CM.Message]
{ warnings :: [CM.Message]
, errors :: [CM.Message]
}

instance Semigroup CompileState where
x <> y = CompileState
{ csWarnings = csWarnings x ++ csWarnings y
, csErrors = csErrors x ++ csErrors y
{ warnings = x.warnings ++ y.warnings
, errors = x.errors ++ y.errors
}

instance Monoid CompileState where
mempty = CompileState
{ csWarnings = []
, csErrors = []
{ warnings = []
, errors = []
}

-- | A custom monad for compilation state as a CYIO-replacement that doesn't track errors in an ExceptT.
Expand All @@ -88,10 +88,10 @@ runCMT cm aux = flip runReaderT aux . flip runStateT mempty . runMaybeT $ cm
catchCYIO :: MonadIO m => CYIO a -> CMT m (Maybe a)
catchCYIO cyio = liftIO (runCYIO cyio) >>= \case
Left es -> do
modify $ \s -> s { csErrors = csErrors s ++ es }
modify $ \s -> s { errors = s.errors ++ es }
return Nothing
Right (x, ws) -> do
modify $ \s -> s { csWarnings = csWarnings s ++ ws }
modify $ \s -> s { warnings = s.warnings ++ ws }
return $ Just x

liftToCM :: Monad m => m a -> CMT m a
Expand All @@ -113,9 +113,9 @@ compileCurryFileWithDeps cfg aux importPaths outDirPath filePath = (fromMaybe me
let defOpts = CO.defaultOptions
cppOpts = CO.optCppOpts defOpts
cppDefs = M.insert "__PAKCS__" 300 (CO.cppDefinitions cppOpts)
opts = CO.defaultOptions { CO.optForce = CFG.cfgForceRecompilation cfg
, CO.optImportPaths = importPaths ++ CFG.cfgImportPaths cfg
, CO.optLibraryPaths = CFG.cfgLibraryPaths cfg
opts = CO.defaultOptions { CO.optForce = cfg.forceRecompilation
, CO.optImportPaths = importPaths ++ cfg.importPaths
, CO.optLibraryPaths = cfg.libraryPaths
, CO.optCppOpts = cppOpts { CO.cppDefinitions = cppDefs }
, CO.optExtensions = nub $ CSE.kielExtensions ++ CO.optExtensions defOpts
, CO.optOriginPragmas = True
Expand Down Expand Up @@ -170,7 +170,7 @@ compileCurryModule opts outDirPath m fp = do
loadAndCheckCurryModule :: MonadIO m => CO.Options -> CI.ModuleIdent -> FilePath -> CMT m (CE.CompEnv ModuleAST)
loadAndCheckCurryModule opts m fp = do
-- Read source file (possibly from VFS)
fl <- asks fileLoader
fl <- asks (.fileLoader)
src <- liftIO $ fl fp
-- Load and check module
loaded <- liftCYIO $ loadCurryModule opts m src fp
Expand Down Expand Up @@ -231,7 +231,7 @@ parseCurryModule opts _ src fp = do
return (lexed, ast)

failedCompilation :: String -> (CompileOutput, CompileState)
failedCompilation msg = (mempty, mempty { csErrors = [makeFailMessage msg] })
failedCompilation msg = (mempty, mempty { errors = [makeFailMessage msg] })

makeFailMessage :: String -> CM.Message
makeFailMessage = CM.message . PP.text
52 changes: 26 additions & 26 deletions src/Curry/LanguageServer/Config.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE RecordWildCards, OverloadedStrings, TypeApplications #-}
{-# LANGUAGE NoFieldSelectors, OverloadedRecordDot, RecordWildCards, OverloadedStrings, TypeApplications #-}
module Curry.LanguageServer.Config
( Config (..)
, LogLevel (..)
Expand All @@ -18,49 +18,49 @@ import Data.Aeson
import Data.Default (Default(..))
import qualified Data.Text as T

newtype LogLevel = LogLevel { llSeverity :: Severity }
newtype LogLevel = LogLevel { severity :: Severity }
deriving (Show, Eq)

data Config = Config { cfgForceRecompilation :: Bool
, cfgImportPaths :: [FilePath]
, cfgLibraryPaths :: [FilePath]
, cfgLogLevel :: LogLevel
, cfgCurryPath :: String
, cfgUseSnippetCompletions :: Bool
data Config = Config { forceRecompilation :: Bool
, importPaths :: [FilePath]
, libraryPaths :: [FilePath]
, logLevel :: LogLevel
, curryPath :: String
, useSnippetCompletions :: Bool
}
deriving (Show, Eq)

instance Default Config where
def = Config { cfgForceRecompilation = False
, cfgImportPaths = []
, cfgLibraryPaths = []
, cfgLogLevel = LogLevel Info
, cfgCurryPath = "pakcs"
, cfgUseSnippetCompletions = False
def = Config { forceRecompilation = False
, importPaths = []
, libraryPaths = []
, logLevel = LogLevel Info
, curryPath = "pakcs"
, useSnippetCompletions = False
}

instance FromJSON Config where
parseJSON = withObject "Config" $ \o -> do
c <- o .: "curry"
l <- c .: "languageServer"
cfgForceRecompilation <- l .:? "forceRecompilation" .!= cfgForceRecompilation def
cfgImportPaths <- l .:? "importPaths" .!= cfgImportPaths def
cfgLibraryPaths <- l .:? "libraryPaths" .!= cfgLibraryPaths def
cfgLogLevel <- l .:? "logLevel" .!= cfgLogLevel def
cfgCurryPath <- l .:? "curryPath" .!= cfgCurryPath def
cfgUseSnippetCompletions <- l .:? "useSnippetCompletions" .!= cfgUseSnippetCompletions def
forceRecompilation <- l .:? "forceRecompilation" .!= (def @Config).forceRecompilation
importPaths <- l .:? "importPaths" .!= (def @Config).importPaths
libraryPaths <- l .:? "libraryPaths" .!= (def @Config).libraryPaths
logLevel <- l .:? "logLevel" .!= (def @Config).logLevel
curryPath <- l .:? "curryPath" .!= (def @Config).curryPath
useSnippetCompletions <- l .:? "useSnippetCompletions" .!= (def @Config).useSnippetCompletions
return Config {..}

instance ToJSON Config where
toJSON Config {..} = object
["curry" .= object
[ "languageServer" .= object
[ "forceRecompilation" .= cfgForceRecompilation
, "importPaths" .= cfgImportPaths
, "libraryPaths" .= cfgLibraryPaths
, "logLevel" .= cfgLogLevel
, "curryPath" .= cfgCurryPath
, "useSnippetCompletions" .= cfgUseSnippetCompletions
[ "forceRecompilation" .= forceRecompilation
, "importPaths" .= importPaths
, "libraryPaths" .= libraryPaths
, "logLevel" .= logLevel
, "curryPath" .= curryPath
, "useSnippetCompletions" .= useSnippetCompletions
]
]
]
Expand Down
6 changes: 3 additions & 3 deletions src/Curry/LanguageServer/Handlers/Diagnostics.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot #-}
module Curry.LanguageServer.Handlers.Diagnostics (emitDiagnostics, fetchDiagnostics) where

import Control.Monad (unless)
Expand Down Expand Up @@ -30,8 +30,8 @@ emitDiagnostics normUri entry = do

fetchDiagnostics :: (MonadIO m, MonadLsp CFG.Config m) => J.NormalizedUri -> ModuleStoreEntry -> m [J.Diagnostic]
fetchDiagnostics normUri entry = do
let warnings = map (curryMsg2Diagnostic J.DsWarning) $ mseWarningMessages entry
errors = map (curryMsg2Diagnostic J.DsError) $ mseErrorMessages entry
let warnings = map (curryMsg2Diagnostic J.DsWarning) entry.warningMessages
errors = map (curryMsg2Diagnostic J.DsError) entry.errorMessages
diags = warnings ++ errors
name = maybe "?" takeBaseName $ normalizedUriToFilePath normUri

Expand Down
4 changes: 2 additions & 2 deletions src/Curry/LanguageServer/Handlers/TextDocument/CodeAction.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, OverloadedRecordDot #-}
module Curry.LanguageServer.Handlers.TextDocument.CodeAction (codeActionHandler) where

-- Curry Compiler Libraries + Dependencies
Expand Down Expand Up @@ -39,7 +39,7 @@ codeActionHandler = S.requestHandler J.STextDocumentCodeAction $ \req responder

fetchCodeActions :: (MonadIO m, MonadLsp CFG.Config m) => J.Range -> I.ModuleStoreEntry -> m [J.CodeAction]
fetchCodeActions range entry = do
actions <- maybe (pure []) (codeActions range) $ I.mseModuleAST entry
actions <- maybe (pure []) (codeActions range) entry.moduleAST
debugM $ "Found " <> T.pack (show (length actions)) <> " code action(s)"
return actions

Expand Down
4 changes: 2 additions & 2 deletions src/Curry/LanguageServer/Handlers/TextDocument/CodeLens.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, OverloadedRecordDot #-}
module Curry.LanguageServer.Handlers.TextDocument.CodeLens (codeLensHandler) where

-- Curry Compiler Libraries + Dependencies
Expand Down Expand Up @@ -40,7 +40,7 @@ codeLensHandler = S.requestHandler J.STextDocumentCodeLens $ \req responder -> d

fetchCodeLenses :: (MonadIO m, MonadLsp CFG.Config m) => I.ModuleStoreEntry -> m [J.CodeLens]
fetchCodeLenses entry = do
lenses <- maybe (pure []) codeLenses $ I.mseModuleAST entry
lenses <- maybe (pure []) codeLenses entry.moduleAST
infoM $ "Found " <> T.pack (show (length lenses)) <> " code lens(es)"
return lenses

Expand Down
62 changes: 31 additions & 31 deletions src/Curry/LanguageServer/Handlers/TextDocument/Completion.hs
Original file line number Diff line number Diff line change
@@ -1,11 +1,11 @@
{-# LANGUAGE OverloadedStrings, FlexibleContexts, FlexibleInstances, MultiWayIf #-}
{-# LANGUAGE NoFieldSelectors, OverloadedStrings, OverloadedRecordDot, FlexibleContexts, FlexibleInstances, MultiWayIf #-}
module Curry.LanguageServer.Handlers.TextDocument.Completion (completionHandler) where

-- Curry Compiler Libraries + Dependencies
import qualified Curry.Syntax as CS
import qualified Base.Types as CT

import Control.Lens ((^.), (.~))
import Control.Lens ((^.), (?~))
import Control.Monad (join, guard)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans (lift)
Expand Down Expand Up @@ -48,7 +48,7 @@ completionHandler = S.requestHandler J.STextDocumentCompletion $ \req responder
query <- MaybeT $ VFS.getCompletionPrefix pos vfile

let opts = CompletionOptions
{ cmoUseSnippets = CFG.cfgUseSnippetCompletions cfg && fromMaybe False (do
{ useSnippets = cfg.useSnippetCompletions && fromMaybe False (do
docCapabilities <- capabilities ^. J.textDocument
cmCapabilities <- docCapabilities ^. J.completion
ciCapabilities <- cmCapabilities ^. J.completionItem
Expand Down Expand Up @@ -101,7 +101,7 @@ importCompletions opts store query = do

generalCompletions :: (MonadIO m, MonadLsp CFG.Config m) => CompletionOptions -> I.ModuleStoreEntry -> I.IndexStore -> VFS.PosPrefixInfo -> m [J.CompletionItem]
generalCompletions opts entry store query = do
let localIdentifiers = join <$> maybe M.empty (`findScopeAtPos` VFS.cursorPos query) (I.mseModuleAST entry)
let localIdentifiers = join <$> maybe M.empty (`findScopeAtPos` VFS.cursorPos query) entry.moduleAST
localIdentifiers' = M.fromList $ map (first ppToText) $ M.toList localIdentifiers
localCompletions = toMatchingCompletions opts query $ uncurry Local <$> M.toList localIdentifiers'
symbols = filter (flip M.notMember localIdentifiers' . I.sIdent) $ nubOrdOn I.sQualIdent
Expand All @@ -125,35 +125,35 @@ data Tagged a = Tagged [J.CompletionItemTag] a

data CompletionSymbol = CompletionSymbol
{ -- The index symbol
cmsSymbol :: I.Symbol
symbol :: I.Symbol
-- The, possibly aliased, module name. Nothing means that the symbol is available unqualified.
, cmsModuleName :: Maybe T.Text
, moduleName :: Maybe T.Text
-- Import edits to apply after the completion has been selected. Nothing means that the symbol does not require an import.
, cmsImportEdits :: Maybe [J.TextEdit]
, importEdits :: Maybe [J.TextEdit]
}

newtype CompletionOptions = CompletionOptions
{ cmoUseSnippets :: Bool
{ useSnippets :: Bool
}

-- | Turns an index symbol into completion symbols by analyzing the module's imports.
toCompletionSymbols :: I.ModuleStoreEntry -> I.Symbol -> [CompletionSymbol]
toCompletionSymbols entry s = do
CS.Module _ _ _ mid _ imps _ <- maybeToList $ I.mseModuleAST entry
CS.Module _ _ _ mid _ imps _ <- maybeToList entry.moduleAST
let pre = "Prelude"
impNames = S.fromList [ppToText mid' | CS.ImportDecl _ mid' _ _ _ <- imps]

if | I.sKind s == I.Module -> return CompletionSymbol
{ cmsSymbol = s
, cmsModuleName = Nothing
, cmsImportEdits = Nothing
{ symbol = s
, moduleName = Nothing
, importEdits = Nothing
}
| (I.sParentIdent s == pre && pre `S.notMember` impNames) || I.sParentIdent s == ppToText mid -> do
m <- [Nothing, Just $ I.sParentIdent s]
return CompletionSymbol
{ cmsSymbol = s
, cmsModuleName = m
, cmsImportEdits = Nothing
{ symbol = s
, moduleName = m
, importEdits = Nothing
}
| otherwise -> do
CS.ImportDecl _ mid' isQual alias spec <- imps
Expand All @@ -167,9 +167,9 @@ toCompletionSymbols entry s = do

m <- moduleNames
return CompletionSymbol
{ cmsSymbol = s
, cmsModuleName = m
, cmsImportEdits = if isImported $ I.sIdent s
{ symbol = s
, moduleName = m
, importEdits = if isImported $ I.sIdent s
then Nothing
else case spec of
Just (CS.Importing _ is) -> do
Expand All @@ -187,8 +187,8 @@ toCompletionSymbols entry s = do
fullName :: CompletionSymbol -> T.Text
fullName cms | I.sKind s == I.Module = I.sQualIdent s
| otherwise = maybe "" (<> ".") moduleName <> I.sIdent s
where s = cmsSymbol cms
moduleName = cmsModuleName cms
where s = cms.symbol
moduleName = cms.moduleName

-- | The fully qualified prefix of the completion query.
fullPrefix :: VFS.PosPrefixInfo -> T.Text
Expand Down Expand Up @@ -219,8 +219,8 @@ class ToCompletionItems a where
instance ToCompletionItems CompletionSymbol where
-- | Converts a Curry value binding to a completion item.
toCompletionItems opts query cms = [makeCompletion name ciKind detail doc insertText insertTextFormat edits]
where s = cmsSymbol cms
edits = cmsImportEdits cms
where s = cms.symbol
edits = cms.importEdits
name = fromMaybe (fullName cms) $ T.stripPrefix (VFS.prefixModule query <> ".") $ fullName cms
ciKind = case I.sKind s of
I.ValueFunction | I.sArrowArity s == Just 0 -> J.CiConstant
Expand All @@ -235,10 +235,10 @@ instance ToCompletionItems CompletionSymbol where
I.TypeClass -> J.CiInterface
I.TypeVar -> J.CiVariable
I.Other -> J.CiText
insertText | cmoUseSnippets opts = Just $ makeSnippet name $ I.sPrintedArgumentTypes s
| otherwise = Just name
insertTextFormat | cmoUseSnippets opts = Just J.Snippet
| otherwise = Just J.PlainText
insertText | opts.useSnippets = Just $ makeSnippet name $ I.sPrintedArgumentTypes s
| otherwise = Just name
insertTextFormat | opts.useSnippets = Just J.Snippet
| otherwise = Just J.PlainText
detail = I.sPrintedType s
doc = Just $ T.intercalate "\n\n" $ filter (not . T.null)
[ if isNothing edits then "" else "_requires import_"
Expand All @@ -264,10 +264,10 @@ instance ToCompletionItems Local where
detail = ppToText <$> t
doc = Just "Local"
argTypes = (ppToText <$>) $ CT.arrowArgs . CT.unpredType =<< maybeToList t
insertText | cmoUseSnippets opts = Just $ makeSnippet i argTypes
| otherwise = Just i
insertTextFormat | cmoUseSnippets opts = Just J.Snippet
| otherwise = Just J.PlainText
insertText | opts.useSnippets = Just $ makeSnippet i argTypes
| otherwise = Just i
insertTextFormat | opts.useSnippets = Just J.Snippet
| otherwise = Just J.PlainText
edits = Nothing

instance ToCompletionItems T.Text where
Expand All @@ -281,7 +281,7 @@ instance ToCompletionItems T.Text where
edits = Nothing

instance ToCompletionItems a => ToCompletionItems (Tagged a) where
toCompletionItems opts query (Tagged tags x) = (J.tags .~ Just (J.List tags)) <$> toCompletionItems opts query x
toCompletionItems opts query (Tagged tags x) = (J.tags ?~ J.List tags) <$> toCompletionItems opts query x

-- | Creates a snippet with VSCode-style syntax.
makeSnippet :: T.Text -> [T.Text] -> T.Text
Expand Down
6 changes: 3 additions & 3 deletions src/Curry/LanguageServer/Handlers/TextDocument/Definition.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot #-}
module Curry.LanguageServer.Handlers.TextDocument.Definition (definitionHandler) where

import Control.Lens ((^.))
Expand Down Expand Up @@ -30,15 +30,15 @@ definitionHandler = S.requestHandler J.STextDocumentDefinition $ \req responder
normUri <- normalizeUriWithPath uri
store <- getStore
defs <- runMaybeT $ do
lift $ debugM $ "Looking up " <> J.getUri (J.fromNormalizedUri normUri) <> " in " <> T.pack (show (M.keys $ I.idxModules store))
lift $ debugM $ "Looking up " <> J.getUri (J.fromNormalizedUri normUri) <> " in " <> T.pack (show (M.keys store.modules))
entry <- I.getModule normUri
lift $ fetchDefinitions store entry pos
responder $ Right $ J.InR $ J.InR $ J.List $ fromMaybe [] defs

fetchDefinitions :: (MonadIO m, MonadLsp CFG.Config m) => I.IndexStore -> I.ModuleStoreEntry -> J.Position -> m [J.LocationLink]
fetchDefinitions store entry pos = do
defs <- (fromMaybe [] <$>) $ runMaybeT $ do
ast <- liftMaybe $ I.mseModuleAST entry
ast <- liftMaybe entry.moduleAST
definitions store ast pos
infoM $ "Found " <> T.pack (show (length defs)) <> " definition(s)"
return defs
Expand Down
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, OverloadedStrings, OverloadedRecordDot #-}
module Curry.LanguageServer.Handlers.TextDocument.DocumentSymbol (documentSymbolHandler) where

import Control.Monad.IO.Class (MonadIO (..))
Expand Down Expand Up @@ -30,6 +30,6 @@ documentSymbolHandler = S.requestHandler J.STextDocumentDocumentSymbol $ \req re

fetchDocumentSymbols :: (MonadIO m, MonadLsp CFG.Config m) => I.ModuleStoreEntry -> m [J.DocumentSymbol]
fetchDocumentSymbols entry = do
let symbols = maybe [] documentSymbols $ I.mseModuleAST entry
let symbols = maybe [] documentSymbols entry.moduleAST
debugM $ "Found document symbols " <> T.pack (show symbols)
return symbols
Loading

0 comments on commit 0abe995

Please sign in to comment.