Interpretation (#298): Scope type

AshleyYakeley · Oct 19, 2024 · 34a4bd0 · 34a4bd0
1 parent 21cbd29
commit 34a4bd0
Show file tree

Hide file tree

Showing 3 changed files with 53 additions and 10 deletions.
diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Interpreter/Register.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Interpreter/Register.hs
@@ -26,7 +26,7 @@ import Pinafore.Language.Type.Subtype ()
 import Pinafore.Language.VarID
 
 registerScope :: QScope -> QScopeBuilder ()
-registerScope scope = registerScopeDocs $ mempty {sdScopes = [scope]}
+registerScope scope = registerScopeDocs $ scopeDocs scope
 
 registerDocs :: Docs -> QScopeBuilder ()
 registerDocs docs = registerScopeDocs $ mempty {sdDocs = docs}

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Interpreter/ScopeDocs.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Interpreter/ScopeDocs.hs
@@ -10,6 +10,9 @@ data QScopeDocs = MkQScopeDocs
     , sdDocs :: Docs
     }
 
+scopeDocs :: QScope -> QScopeDocs
+scopeDocs scope = mempty {sdScopes = [scope]}
+
 instance Semigroup QScopeDocs where
     MkQScopeDocs sa da <> MkQScopeDocs sb db = MkQScopeDocs (sa <> sb) (da <> db)
 
@@ -20,3 +23,9 @@ withScopeDocs :: QScopeDocs -> QInterpreter --> QInterpreter
 withScopeDocs sd ma = do
     scope <- joinAllScopes $ sdScopes sd
     paramLocalM scopeParam (\oldscope -> joinScopes oldscope scope) ma
+
+moduleScopeDocs :: QModule -> QScopeDocs
+moduleScopeDocs MkQModule {..} = let
+    sdScopes = [moduleScope]
+    sdDocs = moduleDoc
+    in MkQScopeDocs {..}
diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Library/Pinafore.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Library/Pinafore.hs
@@ -90,31 +90,54 @@ interpretToValue src = fmap MkLangValue $ parseToValue src []
 langUnifyValue :: LangType '( BottomType, A) -> LangValue -> QInterpreter A
 langUnifyValue t (MkLangValue v) = qUnifyValueTo (langTypeNegative t) v
 
+-- QScopeDocs
+instance HasQGroundType '[] QScopeDocs where
+    qGroundType = stdSingleGroundType $(iowitness [t|'MkWitKind (SingletonFamily QScopeDocs)|]) "Scope.Pinafore."
+
+langWithScope :: QScopeDocs -> QInterpreter A -> QInterpreter A
+langWithScope sdocs = withScopeDocs sdocs
+
+bindScope :: Text -> LangValue -> QScopeDocs
+bindScope name (MkLangValue val@(MkSomeFor t _)) = let
+    fname = fromString $ unpack name
+    doc :: DefDoc
+    doc = MkDefDoc {docItem = ValueDocItem (pure $ fullNameRef fname) $ exprShow t, docDescription = ""}
+    in scopeDocs $ bindingInfosToScope $ pure $ (fname, MkQBindingInfo fname doc $ ValueBinding $ qConstValue val)
+
+interpretModuleFromSource :: Text -> QInterpreter QScopeDocs
+interpretModuleFromSource src = do
+    m <- parseModule src
+    return $ moduleScopeDocs m
+
 pinaforeLibSection :: LibraryStuff
 pinaforeLibSection =
-    headingBDS "Pinafore" "" $
+    headingBDS "Pinafore" "Functions for working with Pinafore source code." $
     pure $
     namespaceBDS
         "Pinafore"
         [ headingBDS
               "Context"
               ""
-              [ typeBDS "Context" "" (qSomeGroundType @_ @QContext) []
+              [ typeBDS "Context" "The context used for running `Interpreter`." (qSomeGroundType @_ @QContext) []
               , namespaceBDS
                     "Context"
                     [specialFormBDS "this" "The context at this point in source." [] "Context.Pinafore" thisContext]
               ]
         , headingBDS
               "Interpreter"
               ""
-              [ typeBDS "Interpreter" "" (qSomeGroundType @_ @QInterpreter) []
+              [ typeBDS
+                    "Interpreter"
+                    "All parsing and type-checking takes place within `Interpreter`."
+                    (qSomeGroundType @_ @QInterpreter)
+                    []
               , namespaceBDS "Interpreter" $ monadEntries @Interpreter <> [valBDS "run" "" langRunInterpreter]
               ]
         , headingBDS
               "Type"
               ""
-              [ typeBDS "Type" "" (qSomeGroundType @_ @LangType) []
-              , specialFormBDS "const.Type" "" ["@A"] "Type.Pinafore A" $
+              [ typeBDS "Type" "A (concrete nonpolar) Pinafore type." (qSomeGroundType @_ @LangType) []
+              , specialFormBDS "const.Type" "A `Type` for a given type." ["@A"] "Type.Pinafore A" $
                 MkQSpecialForm (ConsListType AnnotNonpolarType NilListType) $ \(MkSome (tw :: _ t), ()) -> let
                     stype :: QShimWit 'Positive (LangType '( t, t))
                     stype =
@@ -126,17 +149,28 @@ pinaforeLibSection =
                     sval = MkLangType identityRange tw
                     in return $ constSealedExpression $ MkSomeOf stype sval
               , hasSubtypeRelationBDS @(LangType '( P, Q)) @Showable Verify "" $ functionToShim "show" textShowable
-              , namespaceBDS "Type" [valBDS "unify" "Unify two types." langUnifyTypes]
+              , namespaceBDS "Type" [valBDS "unify" "Unify two `Type`s." langUnifyTypes]
               ]
         , headingBDS
               "Value"
               ""
               [ typeBDS "Value" "" (qSomeGroundType @_ @LangValue) []
               , namespaceBDS
                     "Value"
-                    [ valBDS "mk" "" mkLangValue
-                    , valBDS "unify" "Unify type with value." langUnifyValue
-                    , valBDS "interpret" "Interpret Pinafore source." interpretToValue
+                    [ valBDS "mk" "Create a `Value` from a `Type` and a value." mkLangValue
+                    , valBDS "unify" "Unify a `Type` with a `Value`." langUnifyValue
+                    , valBDS "interpret" "Interpret a Pinafore expression." interpretToValue
                     ]
               ]
+        , headingBDS
+              "Scope"
+              ""
+              [ typeBDS "Scope" "" (qSomeGroundType @_ @QScopeDocs) []
+              , namespaceBDS "Scope" $
+                monoidEntries @QScopeDocs <>
+                [ valBDS "interpret" "Interpret a Pinafore module (list of declarations)." interpretModuleFromSource
+                , valBDS "apply" "Interpret within a given scope." langWithScope
+                , valBDS "bind" "Let-bind a name to a value." bindScope
+                ]
+              ]
         ]