Generalise import statement, for web services etc. (#11, #251)

AshleyYakeley · Apr 17, 2024 · 7c62445 · 7c62445
1 parent 0cb661d
commit 7c62445
Show file tree

Hide file tree

Showing 11 changed files with 25 additions and 23 deletions.
diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language.hs b/Pinafore/pinafore-language/lib/Pinafore/Language.hs
@@ -49,7 +49,7 @@ import Shapes
 runPinaforeScoped :: (?library :: LibraryContext) => String -> QInterpreter a -> InterpretResult a
 runPinaforeScoped sourcename ma =
     runInterpreter (initialPos sourcename) (lcLoadModule ?library) spvals $ do
-        sd <- interpretImportDeclaration builtInModuleName
+        sd <- interpretImportPinaforeDeclaration builtInModuleName
         withScopeDocs sd ma
 
 spvals :: (?library :: LibraryContext) => QSpecialVals

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Error.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Error.hs
@@ -82,6 +82,7 @@ data QErrorType
     | InterpretTypeDeclTypeStorableRecord
     | InterpretSubtypeInconsistent NamedText
                                    NamedText
+    | ImportTypeUnknown Name
     | ModuleNotFoundError ModuleName
     | ModuleCycleError (NonEmpty ModuleName)
 
@@ -212,6 +213,7 @@ instance ShowNamedText QErrorType where
         "subtype relation is inconsistent with existing subtype relation " <> ta <> " <: " <> tb
     showNamedText (ModuleNotFoundError mname) = "can't find module " <> showNamedText mname
     showNamedText (ModuleCycleError nn) = "cycle in modules: " <> (intercalate ", " $ fmap showNamedText $ toList nn)
+    showNamedText (ImportTypeUnknown mtype) = "import type unknown: " <> showNamedText mtype
 
 data QError =
     MkQError SourcePos

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar.hs
@@ -6,7 +6,7 @@ module Pinafore.Language.Grammar
     ) where
 
 import Pinafore.Language.Grammar.Docs as I (Docs)
-import Pinafore.Language.Grammar.Interpret as I (interpretImportDeclaration)
+import Pinafore.Language.Grammar.Interpret as I (interpretImportPinaforeDeclaration)
 import Pinafore.Language.Grammar.Interpret
 import Pinafore.Language.Grammar.Read as I
 import Pinafore.Language.Grammar.Read.Expression as I (operatorFixity)

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/FreeVars.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/FreeVars.hs
@@ -62,8 +62,8 @@ instance SyntaxFreeVariables SyntaxMulticaseList where
 instance SyntaxFreeVariables SyntaxDeclarator where
     syntaxFreeVariables (SDLetSeq sdecls) = syntaxFreeVariables sdecls
     syntaxFreeVariables (SDLetRec sdecls) = syntaxFreeVariables sdecls
-    syntaxFreeVariables (SDImport _) = mempty
-    syntaxFreeVariables (SDWith _) = mempty
+    syntaxFreeVariables SDImport {} = mempty
+    syntaxFreeVariables SDWith {} = mempty
 
 instance SyntaxFreeVariables SyntaxExpression' where
     syntaxFreeVariables (SESubsume expr _) = syntaxFreeVariables expr
@@ -140,8 +140,8 @@ instance SyntaxBindingVariables SyntaxRecursiveDeclaration' where
 instance SyntaxBindingVariables SyntaxDeclarator where
     syntaxBindingVariables (SDLetSeq sdecls) = syntaxBindingVariables sdecls
     syntaxBindingVariables (SDLetRec sdecls) = syntaxBindingVariables sdecls
-    syntaxBindingVariables (SDImport _) = mempty
-    syntaxBindingVariables (SDWith _) = mempty
+    syntaxBindingVariables SDImport {} = mempty
+    syntaxBindingVariables SDWith {} = mempty
 
 instance SyntaxBindingVariables SyntaxDeclaration' where
     syntaxBindingVariables (DirectSyntaxDeclaration bind) = syntaxBindingVariables bind

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Interpret.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Interpret.hs
@@ -3,7 +3,7 @@ module Pinafore.Language.Grammar.Interpret
     , interpretModule
     , interpretDeclarationWith
     , interpretType
-    , interpretImportDeclaration
+    , interpretImportPinaforeDeclaration
     , runInteract
     ) where
 

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Interpret/Expression.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Interpret/Expression.hs
@@ -3,7 +3,7 @@ module Pinafore.Language.Grammar.Interpret.Expression
     , interpretModule
     , interpretDeclarationWith
     , interpretType
-    , interpretImportDeclaration
+    , interpretImportPinaforeDeclaration
     , interpretPattern
     ) where
 
@@ -271,11 +271,15 @@ interpretRecursiveDocDeclarations ddecls = do
     subtypeSB
     interpretRecursiveLetBindings bindingDecls
 
-interpretImportDeclaration :: ModuleName -> QInterpreter QScopeDocs
-interpretImportDeclaration modname = do
+interpretImportPinaforeDeclaration :: ModuleName -> QInterpreter QScopeDocs
+interpretImportPinaforeDeclaration modname = do
     newmod <- getModule modname
     return $ MkQScopeDocs [moduleScope newmod] $ moduleDoc newmod
 
+interpretImportDeclaration :: Maybe Name -> Text -> QInterpreter QScopeDocs
+interpretImportDeclaration Nothing mname = interpretImportPinaforeDeclaration $ MkModuleName mname
+interpretImportDeclaration (Just mtype) _ = throw $ ImportTypeUnknown mtype
+
 interpretDeclaration :: SyntaxDeclaration -> QScopeBuilder ()
 interpretDeclaration (MkSyntaxWithDoc doc (MkWithSourcePos spos decl)) = do
     scopeSetSourcePos spos
@@ -493,8 +497,8 @@ interpretDeclarator (SDLetRec sdecls) = runScopeBuilder $ interpretRecursiveDocD
 interpretDeclarator (SDWith swns) = do
     scopes <- for swns interpretNamespaceWith
     return $ MkQScopeDocs scopes mempty
-interpretDeclarator (SDImport simps) = do
-    scopedocs <- for simps $ \modname -> interpretImportDeclaration modname
+interpretDeclarator (SDImport imptype simps) = do
+    scopedocs <- for simps $ \modname -> interpretImportDeclaration imptype modname
     return $ mconcat scopedocs
 
 interpretDeclaratorWith :: SyntaxDeclarator -> QInterpreter --> QInterpreter

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Read/Expression.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Read/Expression.hs
@@ -408,8 +408,9 @@ readDeclarator =
          return $ SDWith snws) <|>
     (do
          readThis TokImport
-         simps <- readCommaList readModuleName
-         return $ SDImport simps)
+         mqual <- optional readLName
+         simps <- readCommaList $ readThis TokString
+         return $ SDImport mqual simps)
 
 readExpression1 :: Parser SyntaxExpression
 readExpression1 =

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Read/Parser.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Read/Parser.hs
@@ -32,7 +32,6 @@ module Pinafore.Language.Grammar.Read.Parser
     , readNamespaceRef
     , readNamespace
     , readNamespaceQualifier
-    , readModuleName
     , readLines1
     , readLines
     , readOf
@@ -249,11 +248,6 @@ readNamespaceQualifier = do
     readExactlyThis TokOperator $ MkTokenNames False "." []
     readNamespace
 
-readModuleName :: Parser ModuleName
-readModuleName = do
-    s <- readThis TokString
-    return $ MkModuleName s
-
 readLines1 :: Parser a -> Parser (NonEmpty a)
 readLines1 p = do
     a <- try p

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Syntax.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Grammar/Syntax.hs
@@ -111,7 +111,8 @@ data SyntaxNamespaceWith =
 data SyntaxDeclarator
     = SDLetSeq [SyntaxDeclaration]
     | SDLetRec [SyntaxRecursiveDeclaration]
-    | SDImport [ModuleName]
+    | SDImport (Maybe Name)
+               [Text]
     | SDWith [SyntaxNamespaceWith]
     deriving (Eq)
 

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Library/FetchModule.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Library/FetchModule.hs
@@ -36,7 +36,7 @@ instance Contravariant FetchModule where
 
 loadModuleFromText :: Text -> QInterpreter QModule
 loadModuleFromText text = do
-    sd <- interpretImportDeclaration builtInModuleName
+    sd <- interpretImportPinaforeDeclaration builtInModuleName
     withScopeDocs sd $ parseModule text
 
 loadModuleFromByteString :: LazyByteString -> QInterpreter QModule

diff --git a/doc/syntax.md b/doc/syntax.md
@@ -181,7 +181,7 @@ All declarations, including type declarations, are local to a `let` block.
 <declarator> ::=
     "let" <semicolon-separated(<declaration>)> |
     "let" "rec" <semicolon-separated(<direct-declaration>)> |
-    "import" <comma-separated(<module-name>)> |
+    "import" <optional(lname)> <comma-separated(<module-name>)> |
     "with" <comma-separated(<namespace> <with-names> <optional("as" <namespace>)>)>
 
 <declaration> ::=