doc

src/Juvix/Compiler/Concrete/Data/Highlight.hs

@@ -15,9 +15,9 @@ import Juvix.Compiler.Internal.Language qualified as Internal
 import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Data.Context qualified as Internal
 import Juvix.Compiler.Store.Scoped.Data.InfoTable qualified as Scoped
 import Juvix.Data.CodeAnn
-import Juvix.Data.Emacs
 import Juvix.Emacs.Properties
 import Juvix.Emacs.Render
+import Juvix.Emacs.SExp
 import Juvix.Prelude as Prelude hiding (show)
 import Prelude qualified
 
@@ -44,7 +44,7 @@ buildProperties HighlightInput {..} =
           <> mapMaybe goFaceName _highlightNames
           <> map goFaceError _highlightErrors,
       _propertiesGoto = map goGotoProperty _highlightNames,
-      _propertiesDoc = mapMaybe (goDocProperty _highlightDocTable _highlightTypes) _highlightNames
+      _propertiesInfo = mapMaybe (goDocProperty _highlightDocTable _highlightTypes) _highlightNames
     }
 
 goFaceError :: Interval -> WithLoc PropertyFace
@@ -91,9 +91,10 @@ goGotoProperty n = WithLoc (getLoc n) PropertyGoto {..}
     _gotoPos = n ^. anameDefinedLoc . intervalStart
     _gotoFile = n ^. anameDefinedLoc . intervalFile
 
-goDocProperty :: Scoped.DocTable -> Internal.TypesTable -> AName -> Maybe (WithLoc PropertyDoc)
+goDocProperty :: Scoped.DocTable -> Internal.TypesTable -> AName -> Maybe (WithLoc PropertyInfo)
 goDocProperty doctbl tbl a = do
   let ty :: Maybe Internal.Expression = tbl ^. Internal.typesTable . at (a ^. anameDocId)
   d <- ppDocDefault a ty (doctbl ^. at (a ^. anameDocId))
-  let (_docText, _docSExp) = renderEmacs (layoutPretty defaultLayoutOptions d)
-  return (WithLoc (getLoc a) PropertyDoc {..})
+  let (txt, _infoInit) = renderEmacs d
+      _infoInfo = String txt
+  return (WithLoc (getLoc a) PropertyInfo {..})

src/Juvix/Compiler/Nockma/Highlight.hs

@@ -8,11 +8,14 @@ where
 import Juvix.Compiler.Concrete.Data.Highlight (goFaceError, goFaceSemanticItem)
 import Juvix.Compiler.Nockma.Highlight.Base
 import Juvix.Compiler.Nockma.Highlight.Input
-import Juvix.Data.Emacs.SExp
+import Juvix.Compiler.Nockma.Language
+import Juvix.Data.CodeAnn
+import Juvix.Emacs.Render
+import Juvix.Emacs.SExp
 import Juvix.Prelude
 
 highlight :: HighlightInput -> ByteString
-highlight = encodeUtf8 . renderSExp . toSExp . buildProperties
+highlight = encodeUtf8 . renderSExp . withDocTable . toSExp . buildProperties
 
 buildProperties :: HighlightInput -> LocProperties
 buildProperties HighlightInput {..} =
@@ -21,5 +24,66 @@ buildProperties HighlightInput {..} =
         mapMaybe goFaceSemanticItem _highlightSemanticItems
           <> map goFaceError _highlightErrors,
       _propertiesGoto = [],
-      _propertiesDoc = []
+      _propertiesInfo = map goInfoNockOp _highlightNockOps
     }
+
+-- | Used in nockma-mode
+nockOpKey :: NockOp -> Text
+nockOpKey = \case
+  OpAddress -> "OpAddress"
+  OpQuote -> "OpQuote"
+  OpApply -> "OpApply"
+  OpIsCell -> "OpIsCell"
+  OpInc -> "OpInc"
+  OpEq -> "OpEq"
+  OpIf -> "OpIf"
+  OpSequence -> "OpSequence"
+  OpPush -> "OpPush"
+  OpCall -> "OpCall"
+  OpReplace -> "OpReplace"
+  OpHint -> "OpHint"
+  OpScry -> "OpScry"
+
+nockOpDoc :: NockOp -> Doc CodeAnn
+nockOpDoc = \case
+  OpAddress -> "OpAddress"
+  OpQuote -> "OpQuote"
+  OpApply -> "OpApply"
+  OpIsCell -> "OpIsCell"
+  OpInc -> "OpInc"
+  OpEq -> "OpEq"
+  OpIf -> "OpIf"
+  OpSequence -> "OpSequence"
+  OpPush -> "OpPush"
+  OpCall -> "OpCall"
+  OpReplace -> "OpReplace"
+  OpHint -> "OpHint"
+  OpScry -> "OpScry"
+
+-- | nockma-mode depends on this
+docTableVarName :: Text
+docTableVarName = "nockma-doc-table"
+
+-- | NockOp ↦ (txt, init)
+withDocTable :: SExp -> SExp
+withDocTable body =
+  progn
+    [ mkHashTable
+        docTableVarName
+        [ (Quote (Symbol (nockOpKey op)), Quote (Pair (String docTxt) initExpr)) | op <- allElements, let (docTxt, initExpr) = renderEmacs (nockOpDoc op)
+        ],
+      body
+    ]
+
+goInfoNockOp :: WithLoc NockOp -> WithLoc PropertyInfo
+goInfoNockOp = fmap toProperty
+  where
+    toProperty :: NockOp -> PropertyInfo
+    toProperty o =
+      PropertyInfo
+        { _infoInfo = toInfo o,
+          _infoInit = nil
+        }
+
+    toInfo :: NockOp -> SExp
+    toInfo = Symbol . nockOpKey

src/Juvix/Compiler/Nockma/Highlight/Input.hs

@@ -30,16 +30,19 @@ filterInput absPth HighlightInput {..} =
 
 data HighlightBuilder :: Effect where
   HighlightItem :: SemanticItem -> HighlightBuilder m ()
+  HighlightNockOp :: WithLoc NockOp -> HighlightBuilder m ()
 
 makeSem ''HighlightBuilder
 
 ignoreHighlightBuilder :: Sem (HighlightBuilder ': r) a -> Sem r a
 ignoreHighlightBuilder = interpret $ \case
   HighlightItem {} -> return ()
+  HighlightNockOp {} -> return ()
 
 execHighlightBuilder :: Sem (HighlightBuilder ': r) a -> Sem r (HighlightInput)
 execHighlightBuilder = fmap fst . runHighlightBuilder
 
 runHighlightBuilder :: Sem (HighlightBuilder ': r) a -> Sem r (HighlightInput, a)
 runHighlightBuilder = reinterpret (runState emptyHighlightInput) $ \case
   HighlightItem i -> modify (over highlightSemanticItems (i :))
+  HighlightNockOp i -> modify (over highlightNockOps (i :))

src/Juvix/Compiler/Nockma/Translation/FromSource/Base.hs

@@ -170,7 +170,8 @@ dottedNatural = lexeme $ do
 
 atomOp :: Maybe Tag -> Parser (Atom Natural)
 atomOp mtag = do
-  WithLoc loc op' <- withLoc (choice [functionSymbol opName $> op | (opName, op) <- HashMap.toList atomOps])
+  lop@(WithLoc loc op') <- withLoc (choice [functionSymbol opName $> op | (opName, op) <- HashMap.toList atomOps])
+  lift (highlightNockOp lop)
   let info =
         AtomInfo
           { _atomInfoHint = Just AtomHintOp,

src/Juvix/Data/Emacs/Point.hs → src/Juvix/Emacs/Point.hs

@@ -1,4 +1,4 @@
-module Juvix.Data.Emacs.Point
+module Juvix.Emacs.Point
   ( Point,
     unPoint,
     fromZeroBasedInt,

src/Juvix/Emacs/Properties.hs

@@ -3,12 +3,26 @@ module Juvix.Emacs.Properties where
 import Data.Aeson (ToJSON)
 import Data.Aeson qualified as Aeson
 import Data.Aeson.TH
-import Juvix.Data.Emacs
+import Juvix.Emacs.Point
+import Juvix.Emacs.SExp
 import Juvix.Extra.Strings qualified as Str
 import Juvix.Prelude
 
+data PropertyId
+  = PropertyIdFace
+  | PropertyIdGoto
+  | PropertyIdInfo
+  | PropertyIdFormat
+
+propertyIdText :: PropertyId -> Text
+propertyIdText = \case
+  PropertyIdFace -> "face"
+  PropertyIdInfo -> "juvix-info"
+  PropertyIdGoto -> "juvix-goto"
+  PropertyIdFormat -> "juvix-format"
+
 data GenericProperty = GenericProperty
-  { _gpropProperty :: Text,
+  { _gpropProperty :: PropertyId,
     _gpropValue :: SExp
   }
 
@@ -65,7 +79,7 @@ instance ToJSON Face where
 data EmacsProperty
   = EPropertyGoto PropertyGoto
   | EPropertyFace PropertyFace
-  | EPropertyDoc PropertyDoc
+  | EPropertyInfo PropertyInfo
 
 type LocEmacsProperty = WithLoc EmacsProperty
 
@@ -78,15 +92,15 @@ newtype PropertyFace = PropertyFace
   { _faceFace :: Face
   }
 
-data PropertyDoc = PropertyDoc
-  { _docText :: Text,
-    _docSExp :: SExp
+data PropertyInfo = PropertyInfo
+  { _infoInfo :: SExp,
+    _infoInit :: SExp
   }
 
 data LocProperties = LocProperties
   { _propertiesGoto :: [WithLoc PropertyGoto],
     _propertiesFace :: [WithLoc PropertyFace],
-    _propertiesDoc :: [WithLoc PropertyDoc]
+    _propertiesInfo :: [WithLoc PropertyInfo]
   }
 
 data RawProperties = RawProperties
@@ -121,7 +135,7 @@ rawProperties LocProperties {..} =
   RawProperties
     { _rawPropertiesGoto = map (rawWithLoc rawGoto) _propertiesGoto,
       _rawPropertiesFace = map (rawWithLoc rawFace) _propertiesFace,
-      _rawPropertiesDoc = map (rawWithLoc rawType) _propertiesDoc
+      _rawPropertiesDoc = map (rawWithLoc rawType) _propertiesInfo
     }
   where
     rawInterval :: Interval -> RawInterval
@@ -137,8 +151,11 @@ rawProperties LocProperties {..} =
     rawWithLoc :: (a -> b) -> WithLoc a -> RawWithLoc b
     rawWithLoc f x = (rawInterval (getLoc x), f (x ^. withLocParam))
 
-    rawType :: PropertyDoc -> RawType
-    rawType PropertyDoc {..} = _docText
+    rawType :: PropertyInfo -> RawType
+    rawType PropertyInfo {..} = case _infoInfo of
+      Symbol s -> s
+      String s -> s
+      _ -> error "unsupported"
 
     rawFace :: PropertyFace -> RawFace
     rawFace PropertyFace {..} = _faceFace
@@ -153,7 +170,7 @@ rawProperties LocProperties {..} =
 instance IsProperty EmacsProperty where
   toProperties = \case
     EPropertyFace p -> toProperties p
-    EPropertyDoc p -> toProperties p
+    EPropertyInfo p -> toProperties p
     EPropertyGoto p -> toProperties p
 
 addGenericProperties :: WithRange (NonEmpty GenericProperty) -> SExp
@@ -166,7 +183,7 @@ addGenericProperties (WithRange i props) =
     propertyList = mkList (concat [[k, v] | (k, v) <- map mkItem (toList props)])
       where
         mkItem :: GenericProperty -> (SExp, SExp)
-        mkItem GenericProperty {..} = (Symbol _gpropProperty, _gpropValue)
+        mkItem GenericProperty {..} = (Symbol (propertyIdText _gpropProperty), _gpropValue)
 
 putProperty :: (IsProperty a) => WithRange a -> SExp
 putProperty = addGenericProperties . fmap toProperties
@@ -185,29 +202,29 @@ instance IsProperty PropertyFace where
   toProperties PropertyFace {..} =
     pure
       GenericProperty
-        { _gpropProperty = "face",
+        { _gpropProperty = PropertyIdFace,
           _gpropValue = toSExp _faceFace
         }
 
 instance IsProperty PropertyGoto where
   toProperties PropertyGoto {..} =
     pure
       GenericProperty
-        { _gpropProperty = "juvix-goto",
+        { _gpropProperty = PropertyIdGoto,
           _gpropValue = gotoPair
         }
     where
       gotoPair = Pair (String (pack (toFilePath _gotoFile))) (Int (_gotoPos ^. locOffset . to (succ . fromIntegral)))
 
-instance IsProperty PropertyDoc where
-  toProperties PropertyDoc {..} =
+instance IsProperty PropertyInfo where
+  toProperties PropertyInfo {..} =
     GenericProperty
-      { _gpropProperty = "help-echo",
-        _gpropValue = String _docText
+      { _gpropProperty = PropertyIdInfo,
+        _gpropValue = _infoInfo
       }
       :| [ GenericProperty
-             { _gpropProperty = "juvix-format",
-               _gpropValue = _docSExp
+             { _gpropProperty = PropertyIdFormat,
+               _gpropValue = _infoInit
              }
          ]
 
@@ -216,5 +233,5 @@ instance ToSExp LocProperties where
     progn
       ( map putPropertyLoc _propertiesFace
           <> map putPropertyLoc _propertiesGoto
-          <> map putPropertyLoc _propertiesDoc
+          <> map putPropertyLoc _propertiesInfo
       )

src/Juvix/Emacs/Render.hs

@@ -1,9 +1,10 @@
-module Juvix.Emacs.Render where
+module Juvix.Emacs.Render (renderEmacs, nameKindFace) where
 
 import Data.Text qualified as Text
 import Juvix.Data.CodeAnn
-import Juvix.Data.Emacs
+import Juvix.Emacs.Point
 import Juvix.Emacs.Properties
+import Juvix.Emacs.SExp
 import Juvix.Prelude
 
 nameKindFace :: NameKind -> Maybe Face
@@ -44,9 +45,15 @@ data RenderState = RenderState
 
 makeLenses ''RenderState
 
-renderEmacs :: SimpleDocStream CodeAnn -> (Text, SExp)
+renderEmacs :: Doc CodeAnn -> (Text, SExp)
 renderEmacs s =
-  let r = run . execState iniRenderState . go . alterAnnotationsS fromCodeAnn $ s
+  let r =
+        run
+          . execState iniRenderState
+          . go
+          . alterAnnotationsS fromCodeAnn
+          . layoutPretty defaultLayoutOptions
+          $ s
    in (r ^. stateText, progn (map putProperty (r ^. stateProperties)))
   where
     iniRenderState =