something

seastian · seastian · commit c94b046c9e3e · 2024-09-23T20:01:52.000+02:00
diff --git a/purescript.cabal b/purescript.cabal
@@ -274,6 +274,8 @@ library
     Language.PureScript.CST.Parser
     Language.PureScript.CST.Positions
     Language.PureScript.CST.Print
+    Language.PureScript.Ide.ToIde
+    Language.PureScript.Ide.ToI
     Language.PureScript.CST.Traversals
     Language.PureScript.CST.Traversals.Type
     Language.PureScript.CST.Types
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
@@ -199,7 +199,7 @@ shushProgress ma =
 -- | Stops any kind of codegen
 shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
 shushCodegen ma =
-  ma { P.codegen = \_ _ _ -> pure ()
+  ma { P.codegen = \_ _ _ _ -> pure ()
      , P.ffiCodegen = \_ -> pure ()
      }
 
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
@@ -24,11 +24,14 @@ import Protolude
 
 import Control.Parallel.Strategies (withStrategy, parList, rseq)
 import Data.Map qualified as Map
-import Language.PureScript qualified as P
 import Language.PureScript.CST qualified as CST
 import Language.PureScript.Ide.Error (IdeError)
 import Language.PureScript.Ide.Types (DefinitionSites, IdeNamespace(..), IdeNamespaced(..), TypeAnnotations)
 import Language.PureScript.Ide.Util (ideReadFile)
+import Language.PureScript.AST.Declarations qualified as P
+import Language.PureScript.AST.SourcePos qualified as P
+import Language.PureScript.Names qualified as P
+import Language.PureScript.Types qualified as P
 
 parseModule :: FilePath -> Text -> Either FilePath (FilePath, P.Module)
 parseModule path file =
diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs
@@ -19,6 +19,7 @@ module Language.PureScript.Ide.State
   ( getLoadedModulenames
   , getExternFiles
   , getFileState
+  , toIdeDeclarationAnn
   , resetIdeState
   , cacheRebuild
   , cachedRebuild
@@ -251,6 +252,20 @@ populateVolatileStateSTM ref = do
   setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache)
   pure (force results)
 
+toIdeDeclarationAnn :: P.Module -> ExternsFile -> [IdeDeclarationAnn]
+toIdeDeclarationAnn m e = results
+  where
+  asts = extractAstInformation m
+  (moduleDeclarations, reexportRefs) = convertExterns e
+  results =
+        moduleDeclarations
+        & resolveDataConstructorsForModule
+        & resolveLocationsForModule asts
+        & resolveDocumentationForModule m
+        -- & resolveInstances externs
+        -- & resolveOperators
+        -- & resolveReexports reexportRefs
+
 resolveLocations
   :: ModuleMap (DefinitionSites P.SourceSpan, TypeAnnotations)
   -> ModuleMap [IdeDeclarationAnn]
diff --git a/src/Language/PureScript/Ide/ToIde.hs b/src/Language/PureScript/Ide/ToIde.hs
@@ -0,0 +1,156 @@
+module Language.PureScript.Ide.ToIde where
+
+import Protolude hiding (moduleName, unzip)
+
+import Control.Concurrent.STM (TVar, modifyTVar, readTVar, readTVarIO, writeTVar)
+import Control.Lens (Ixed(..), preview, view, (%~), (.~), (^.))
+import Data.IORef (readIORef, writeIORef)
+import Data.Map.Lazy qualified as Map
+import Data.Time.Clock (UTCTime)
+import Data.Zip (unzip)
+import Language.PureScript.Docs.Convert.Single (convertComments)
+import Language.PureScript.Externs (ExternsDeclaration(..), ExternsFile(..))
+import Language.PureScript.Ide.Externs (convertExterns)
+import Language.PureScript.Ide.SourceFile (extractAstInformation)
+import Language.PureScript.Ide.Types
+import Language.PureScript.Ide.Util (discardAnn, displayTimeSpec, logPerf, opNameT, properNameT, runLogger)
+import System.Directory (getModificationTime)
+import Database.SQLite.Simple qualified as SQLite
+import Debug.Trace qualified as Debug
+import Language.PureScript.AST.Declarations (Module (..))
+import Language.PureScript.AST.SourcePos qualified as P
+import Language.PureScript.Names qualified as P
+import Data.Text (Text)
+import Language.PureScript.AST.Declarations qualified as P
+import Language.PureScript.Comments qualified as P
+import Data.Maybe (Maybe)
+
+toIdeDeclarationAnn :: Module -> ExternsFile -> [IdeDeclarationAnn]
+toIdeDeclarationAnn m e = results
+  where
+  asts = extractAstInformation m
+  (moduleDeclarations, reexportRefs) = convertExterns e
+  results =
+        moduleDeclarations
+        -- & resolveDataConstructorsForModule
+        & resolveLocationsForModule asts
+        & resolveDocumentationForModule m
+        -- & resolveInstances externs
+        -- & resolveOperators
+        -- & resolveReexports reexportRefs
+
+
+resolveLocationsForModule
+  :: (DefinitionSites P.SourceSpan, TypeAnnotations)
+  -> [IdeDeclarationAnn]
+  -> [IdeDeclarationAnn]
+resolveLocationsForModule (defs, types) =
+  map convertDeclaration
+  where
+    convertDeclaration :: IdeDeclarationAnn -> IdeDeclarationAnn
+    convertDeclaration (IdeDeclarationAnn ann d) = convertDeclaration'
+      annotateFunction
+      annotateValue
+      annotateDataConstructor
+      annotateType
+      annotateType -- type classes live in the type namespace
+      annotateModule
+      d
+      where
+        annotateFunction x = IdeDeclarationAnn (ann { _annLocation = Map.lookup (IdeNamespaced IdeNSValue (P.runIdent x)) defs
+                                                    , _annTypeAnnotation = Map.lookup x types
+                                                    })
+        annotateValue x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs})
+        annotateDataConstructor x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSValue x) defs})
+        annotateType x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSType x) defs})
+        annotateModule x = IdeDeclarationAnn (ann {_annLocation = Map.lookup (IdeNamespaced IdeNSModule x) defs})
+
+convertDeclaration'
+  :: (P.Ident -> IdeDeclaration -> IdeDeclarationAnn)
+  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+  -> (Text -> IdeDeclaration -> IdeDeclarationAnn)
+  -> IdeDeclaration
+  -> IdeDeclarationAnn
+convertDeclaration' annotateFunction annotateValue annotateDataConstructor annotateType annotateClass annotateModule d =
+  case d of
+    IdeDeclValue v ->
+      annotateFunction (v ^. ideValueIdent) d
+    IdeDeclType t ->
+      annotateType (t ^. ideTypeName . properNameT) d
+    IdeDeclTypeSynonym s ->
+      annotateType (s ^. ideSynonymName . properNameT) d
+    IdeDeclDataConstructor dtor ->
+      annotateDataConstructor (dtor ^. ideDtorName . properNameT) d
+    IdeDeclTypeClass tc ->
+      annotateClass (tc ^. ideTCName . properNameT) d
+    IdeDeclValueOperator operator ->
+      annotateValue (operator ^. ideValueOpName . opNameT) d
+    IdeDeclTypeOperator operator ->
+      annotateType (operator ^. ideTypeOpName . opNameT) d
+    IdeDeclModule mn ->
+      annotateModule (P.runModuleName mn) d
+
+resolveDocumentationForModule
+  :: Module
+    -> [IdeDeclarationAnn]
+    -> [IdeDeclarationAnn]
+resolveDocumentationForModule (Module _ moduleComments moduleName sdecls _) =
+  map convertDecl
+  where
+  extractDeclComments :: P.Declaration -> [(P.Name, [P.Comment])]
+  extractDeclComments = \case
+    P.DataDeclaration (_, cs) _ ctorName _ ctors ->
+      (P.TyName ctorName, cs) : map dtorComments ctors
+    P.TypeClassDeclaration (_, cs) tyClassName _ _ _ members ->
+      (P.TyClassName tyClassName, cs) : concatMap extractDeclComments members
+    decl ->
+      maybe [] (\name' -> [(name', snd (P.declSourceAnn decl))]) (name decl)
+
+  comments :: Map.Map P.Name [P.Comment]
+  comments = Map.insert (P.ModName moduleName) moduleComments $
+    Map.fromListWith (flip (<>)) $ concatMap extractDeclComments sdecls
+
+  dtorComments :: P.DataConstructorDeclaration -> (P.Name, [P.Comment])
+  dtorComments dcd = (P.DctorName (P.dataCtorName dcd), snd (P.dataCtorAnn dcd))
+
+  name :: P.Declaration -> Maybe P.Name
+  name (P.TypeDeclaration d) = Just $ P.IdentName $ P.tydeclIdent d
+  name decl = P.declName decl
+
+  convertDecl :: IdeDeclarationAnn -> IdeDeclarationAnn
+  convertDecl (IdeDeclarationAnn ann d) =
+    convertDeclaration'
+      (annotateValue . P.IdentName)
+      (annotateValue . P.IdentName . P.Ident)
+      (annotateValue . P.DctorName . P.ProperName)
+      (annotateValue . P.TyName . P.ProperName)
+      (annotateValue . P.TyClassName . P.ProperName)
+      (annotateValue . P.ModName . P.moduleNameFromString)
+      d
+    where
+      docs :: P.Name -> Text
+      docs ident = fromMaybe "" $ convertComments =<< Map.lookup ident comments
+
+      annotateValue ident = IdeDeclarationAnn (ann { _annDocumentation = Just $ docs ident })
+
+-- resolveDataConstructorsForModule
+--   :: [IdeDeclarationAnn]
+--   -> [IdeDeclarationAnn]
+-- resolveDataConstructorsForModule decls =
+--   map (idaDeclaration %~ resolveDataConstructors) decls
+--   where
+--     resolveDataConstructors :: IdeDeclaration -> IdeDeclaration
+--     resolveDataConstructors decl = case decl of
+--       IdeDeclType ty ->
+--         IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty ^. ideTypeName) dtors))
+--       _ ->
+--         decl
+--
+--     dtors =
+--       decls
+--       & Map.mapMaybe (preview (idaDeclaration . _IdeDeclDataConstructor))
+--       & foldr (\(IdeDataConstructor name typeName type') ->
+--                   Map.insertWith (<>) typeName [(name, type')]) Map.empty
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
@@ -132,7 +132,7 @@ rebuildModuleWithIndex MakeActions{..} exEnv externs m@(Module _ _ moduleName _
                  ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs
                Right d -> d
 
-  evalSupplyT nextVar'' $ codegen renamed docs exts
+  evalSupplyT nextVar'' $ codegen withPrim renamed docs exts
   return exts
 
 -- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
@@ -34,7 +34,7 @@ import Data.Text.Encoding qualified as TE
 import Data.Time.Clock (UTCTime)
 import Data.Version (showVersion)
 import Language.JavaScript.Parser qualified as JS
-import Language.PureScript.AST (SourcePos(..))
+import Language.PureScript.AST (SourcePos(..), Module)
 import Language.PureScript.Bundle qualified as Bundle
 import Language.PureScript.CodeGen.JS qualified as J
 import Language.PureScript.CodeGen.JS.Printer (prettyPrintJS, prettyPrintJSWithSourceMaps)
@@ -113,7 +113,7 @@ data MakeActions m = MakeActions
   , readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile)
   -- ^ Read the externs file for a module as a string and also return the actual
   -- path for the file.
-  , codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
+  , codegen :: Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
   -- ^ Run the code generator for the module and write any required output files.
   , ffiCodegen :: CF.Module CF.Ann -> m ()
   -- ^ Check ffi and print it in the output directory.
@@ -247,12 +247,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
     when (S.member Docs codegenTargets) $ for_ Docs.Prim.primModules $ \docsMod@Docs.Module{..} ->
       writeJSONFile (outputFilename modName "docs.json") docsMod
 
-  codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
-  codegen m docs exts = do
+  codegen :: Module -> CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
+  codegen ast m docs exts = do
     let mn = CF.moduleName m
     lift $ writeCborFile (outputFilename mn externsFileName) exts
     lift $ sqliteInit outputDir
-    lift $ sqliteExtern outputDir docs exts
+    lift $ sqliteExtern outputDir ast docs exts
     codegenTargets <- lift $ asks optionsCodegenTargets
     when (S.member CoreFn codegenTargets) $ do
       let coreFnFile = targetFilename mn CoreFn
diff --git a/src/Language/PureScript/Make/IdeCache.hs b/src/Language/PureScript/Make/IdeCache.hs
@@ -1,6 +1,8 @@
 module Language.PureScript.Make.IdeCache where
 
 import Prelude
+
+import Language.PureScript.Ide.ToIde (toIdeDeclarationAnn)
 import Database.SQLite.Simple (NamedParam(..))
 import Database.SQLite.Simple qualified as SQLite
 import Codec.Serialise qualified as Serialise
@@ -29,9 +31,10 @@ import Language.PureScript.Docs.AsMarkdown (codeToString, declAsMarkdown, runDoc
 import Codec.Serialise (serialise)
 import Data.Aeson (encode)
 import Debug.Trace qualified as Debug
+import Language.PureScript.AST.Declarations (Module)
 
-sqliteExtern :: (MonadIO m) => FilePath -> Docs.Module -> ExternsFile -> m ()
-sqliteExtern outputDir docs extern = liftIO $ do 
+sqliteExtern :: (MonadIO m) => FilePath -> Module -> Docs.Module -> ExternsFile -> m ()
+sqliteExtern outputDir m docs extern = liftIO $ do 
     conn <- SQLite.open db
     withRetry $ SQLite.executeNamed conn
       "INSERT INTO modules (module_name, comment, extern, dec) VALUES (:module_name, :docs, :extern, :dec)" 
@@ -47,11 +50,7 @@ sqliteExtern outputDir docs extern = liftIO $ do
         , ":dependency" := runModuleName (eiModule i)
         ])
 
-
-    Debug.traceM $ show $  convertExterns extern
-    Debug.traceM $ show $ Docs.modDeclarations docs
-
-    for_ (fst $ convertExterns extern) (\ideDeclaration -> do
+    for_ (toIdeDeclarationAnn m extern) (\ideDeclaration -> do
        withRetry $ SQLite.executeNamed conn
           ("INSERT INTO ide_declarations (module_name, name, namespace, declaration_type, span, declaration) " <>
            "VALUES (:module_name, :name, :namespace, :declaration_type, :span, :declaration)"

Original file line number	Diff line number	Diff line change
`@@ -199,7 +199,7 @@ shushProgress ma =`
`199`	`199`	`-- \| Stops any kind of codegen`
`200`	`200`	`shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m`
`201`	`201`	`shushCodegen ma =`
`202`		`- ma { P.codegen = \_ _ _ -> pure ()`
	`202`	`+ ma { P.codegen = \_ _ _ _ -> pure ()`
`203`	`203`	`, P.ffiCodegen = \_ -> pure ()`
`204`	`204`	`}`
`205`	`205`