Splices (#317): quote & splice code

Pinafore/pinafore-language/lib/Pinafore/Language/Convert.hs

@@ -4,4 +4,5 @@ module Pinafore.Language.Convert
 
 import Pinafore.Language.Convert.HasType as I
 import Pinafore.Language.Convert.Literal as I
+import Pinafore.Language.Convert.Pinafore as I
 import Pinafore.Language.Convert.Types ()

Pinafore/pinafore-language/lib/Pinafore/Language/Convert/Pinafore.hs

@@ -0,0 +1,58 @@
+{-# OPTIONS -fno-warn-orphans #-}
+
+module Pinafore.Language.Convert.Pinafore where
+
+import Import
+import Pinafore.Language.Convert.HasType
+import Pinafore.Language.Interpreter
+import Pinafore.Language.Library.Types
+import Pinafore.Language.Type
+
+-- LangType
+data LangType (pq :: (Type, Type)) =
+    forall a. MkLangType (QRange a pq)
+                         (QNonpolarType a)
+
+instance CatFunctor (CatRange (->)) (->) LangType where
+    cfmap f (MkLangType r v) = MkLangType (cfmap f r) v
+
+instance ShowText (LangType pq) where
+    showText (MkLangType _ v) = toText $ exprShow v
+
+instance MaybeRepresentational LangType where
+    maybeRepresentational = Nothing
+
+instance HasCCRVariance 'RangeCCRVariance LangType
+
+instance HasQGroundType '[ RangeCCRVariance] LangType where
+    qGroundType = stdSingleGroundType $(iowitness [t|'MkWitKind (SingletonFamily LangType)|]) "Type.Pinafore."
+
+mkLangTypeValue :: Some QNonpolarType -> QValue
+mkLangTypeValue (MkSome (tw :: _ t)) = let
+    stype :: QShimWit 'Positive (LangType '( t, t))
+    stype = rangeShimWit qGroundType (nonpolarToNegative @QTypeSystem tw) (nonpolarToPositive @QTypeSystem tw)
+    sval :: LangType '( t, t)
+    sval = MkLangType identityRange tw
+    in MkSomeOf stype sval
+
+-- QInterpreter
+instance HasQGroundType '[ CoCCRVariance] QInterpreter where
+    qGroundType =
+        stdSingleGroundType $(iowitness [t|'MkWitKind (SingletonFamily QInterpreter)|]) "Interpreter.Pinafore."
+
+newtype LangExpression = MkLangExpression
+    { unLangExpression :: QExpression
+    }
+
+-- LangExpression
+instance HasQGroundType '[] LangExpression where
+    qGroundType =
+        stdSingleGroundType $(iowitness [t|'MkWitKind (SingletonFamily LangExpression)|]) "Expression.Pinafore."
+
+-- QScopeDocs
+instance HasQGroundType '[] QScopeDocs where
+    qGroundType = stdSingleGroundType $(iowitness [t|'MkWitKind (SingletonFamily QScopeDocs)|]) "Scope.Pinafore."
+
+-- Anchor
+instance HasQGroundType '[] Anchor where
+    qGroundType = stdSingleGroundType $(iowitness [t|'MkWitKind (SingletonFamily Anchor)|]) "Anchor.Pinafore."

Pinafore/pinafore-language/lib/Pinafore/Language/Interpret/Expression.hs

@@ -9,6 +9,7 @@ module Pinafore.Language.Interpret.Expression
 
 import Data.Graph hiding (Forest, Tree)
 import Import
+import Pinafore.Language.Convert.Pinafore
 import Pinafore.Language.Debug
 import Pinafore.Language.Error
 import Pinafore.Language.Expression
@@ -347,6 +348,12 @@ interpretDeclaration (MkSyntaxWithDoc doc (MkWithSourcePos spos decl)) = do
                  else id) $
             for_ decls interpretDeclaration
         DocSectionSyntaxDeclaration heading decls -> sectionHeading heading doc $ for_ decls interpretDeclaration
+        SpliceSyntaxDeclaration sexpr -> do
+            sd <-
+                builderLift $ do
+                    expr <- interpretExpression sexpr
+                    spliceDecls expr
+            registerScopeDocs sd
         DebugSyntaxDeclaration nameref -> do
             mfd <- builderLift $ lookupDebugBindingInfo nameref
             liftIO $
@@ -530,6 +537,27 @@ interpretExpression' (SEDebug t sexpr) = do
     expr <- interpretExpression sexpr
     liftIO $ debugMessage $ t <> ": " <> pack (show expr)
     return expr
+interpretExpression' (SESplice sexpr) = do
+    expr <- interpretExpression sexpr
+    spliceExpression expr
+interpretExpression' (SEQuoteExpression sexpr) = return $ qConst $ fmap MkLangExpression $ interpretExpression sexpr
+interpretExpression' (SEQuoteScope sdecls) = return $ qConst $ interpretScopeDocs sdecls
+interpretExpression' (SEQuoteType stype) = do
+    t <- interpretNonpolarType stype
+    return $ qConstValue $ mkLangTypeValue t
+interpretExpression' (SEQuoteAnchor anchor) = return $ qConst anchor
+
+spliceExpression :: QExpression -> QInterpreter QExpression
+spliceExpression spliceexpr = do
+    val <- qEvalExpr spliceexpr
+    mexpr <- qUnifyValue @(QInterpreter LangExpression) val
+    fmap unLangExpression mexpr
+
+spliceDecls :: QExpression -> QInterpreter QScopeDocs
+spliceDecls spliceexpr = do
+    val <- qEvalExpr spliceexpr
+    msd <- qUnifyValue @(QInterpreter QScopeDocs) val
+    msd
 
 checkExprVars :: QExpression -> QInterpreter ()
 checkExprVars (MkSealedExpression _ expr) = do
@@ -635,8 +663,11 @@ interpretSubtypeRelation trustme sta stb mbody docDescription = do
         docItem = SubtypeRelationDocItem {..}
     registerDocs $ pure MkDefDoc {..}
 
+interpretScopeDocs :: [SyntaxDeclaration] -> QInterpreter QScopeDocs
+interpretScopeDocs sdecls = runScopeBuilder $ for_ sdecls interpretDeclaration
+
 interpretModule :: SyntaxModule -> QInterpreter QModule
 interpretModule (MkSyntaxModule sdecls) = do
-    MkQScopeDocs scopes docs <- runScopeBuilder $ for_ sdecls interpretDeclaration
+    MkQScopeDocs scopes docs <- interpretScopeDocs sdecls
     scope <- joinAllScopes scopes
     return $ MkQModule docs scope

Pinafore/pinafore-language/lib/Pinafore/Language/Interpret/FreeVars.hs

@@ -83,7 +83,6 @@ instance SyntaxFreeVariables SyntaxExpression' where
     syntaxFreeVariables (SEConst sc) = syntaxFreeVariables sc
     syntaxFreeVariables (SEImplicitVar _) = mempty
     syntaxFreeVariables (SEVar ns name mb) = (opoint $ namespaceConcatFullName ns name) <> syntaxFreeVariables mb
-    syntaxFreeVariables (SESpecialForm _ _) = mempty
     syntaxFreeVariables (SEApply f arg) = union (syntaxFreeVariables f) (syntaxFreeVariables arg)
     syntaxFreeVariables (SEAbstract match) = syntaxFreeVariables match
     syntaxFreeVariables (SEAbstracts match) = syntaxFreeVariables match
@@ -98,6 +97,12 @@ instance SyntaxFreeVariables SyntaxExpression' where
             (syntaxFreeVariables decl <> syntaxFreeVariables expr)
             (mapMaybe btGetVar $ syntaxBindingVariables decl)
     syntaxFreeVariables (SEList exprs) = syntaxFreeVariables exprs
+    syntaxFreeVariables (SESpecialForm _ _) = mempty
+    syntaxFreeVariables (SESplice _) = mempty
+    syntaxFreeVariables (SEQuoteExpression _) = mempty
+    syntaxFreeVariables (SEQuoteScope _) = mempty
+    syntaxFreeVariables (SEQuoteType _) = mempty
+    syntaxFreeVariables (SEQuoteAnchor _) = mempty
     syntaxFreeVariables (SEDebug _ expr) = syntaxFreeVariables expr
 
 instance SyntaxFreeVariables SyntaxBinding where

Pinafore/pinafore-language/lib/Pinafore/Language/Library/Pinafore.hs

@@ -34,37 +34,13 @@ thisContext =
             sval = MkQContext $ MkLibraryContext lm
         return $ constSealedExpression $ MkSomeOf qType sval
 
--- QInterpreter
-instance HasQGroundType '[ CoCCRVariance] QInterpreter where
-    qGroundType =
-        stdSingleGroundType $(iowitness [t|'MkWitKind (SingletonFamily QInterpreter)|]) "Interpreter.Pinafore."
-
 langRunInterpreter :: QContext -> QInterpreter A -> Action (Result Text A)
 langRunInterpreter (MkQContext lc) ia = let
     ?library = lc
     in do
            rea <- runInterpretResult $ runPinaforeScoped "<evaluate>" ia
            return $ mapResultFailure showText rea
 
--- LangType
-data LangType (pq :: (Type, Type)) =
-    forall a. MkLangType (QRange a pq)
-                         (QNonpolarType a)
-
-instance CatFunctor (CatRange (->)) (->) LangType where
-    cfmap f (MkLangType r v) = MkLangType (cfmap f r) v
-
-instance ShowText (LangType pq) where
-    showText (MkLangType _ v) = toText $ exprShow v
-
-instance MaybeRepresentational LangType where
-    maybeRepresentational = Nothing
-
-instance HasCCRVariance 'RangeCCRVariance LangType
-
-instance HasQGroundType '[ RangeCCRVariance] LangType where
-    qGroundType = stdSingleGroundType $(iowitness [t|'MkWitKind (SingletonFamily LangType)|]) "Type.Pinafore."
-
 langTypePositive :: LangType '( p, q) -> QShimWit 'Positive p
 langTypePositive (MkLangType r t) = mapShimWit (MkPolarShim $ rangeContra r) $ nonpolarToPositive @QTypeSystem t
 
@@ -90,10 +66,6 @@ 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
 

Pinafore/pinafore-language/lib/Pinafore/Language/Library/Types.hs

@@ -15,7 +15,6 @@ module Pinafore.Language.Library.Types
     ) where
 
 import Import
-import Pinafore.Language.Library.Convert ()
 import Pinafore.Language.Type
 
 openEntityShimWit :: forall tid. OpenEntityType tid -> QShimWit 'Positive (OpenEntity tid)

Pinafore/pinafore-language/package.yaml

@@ -70,6 +70,7 @@ library:
       - Pinafore.Language.Convert.HasType
       - Pinafore.Language.Convert.Literal
       - Pinafore.Language.Convert.Types
+      - Pinafore.Language.Convert.Pinafore
       - Pinafore.Language.Convert
       - Pinafore.Language.Type.GetDynamicSupertype
       - Pinafore.Language.Type.Subtype.Hint

Pinafore/pinafore-language/pinafore-language.cabal

@@ -60,6 +60,7 @@ library
       Pinafore.Language.Convert.HasType
       Pinafore.Language.Convert.Literal
       Pinafore.Language.Convert.Types
+      Pinafore.Language.Convert.Pinafore
       Pinafore.Language.Convert
       Pinafore.Language.Type.GetDynamicSupertype
       Pinafore.Language.Type.Subtype.Hint

Pinafore/pinafore-syntax/lib/Pinafore/Syntax/Parse/Expression.hs

@@ -257,6 +257,7 @@ readDeclaration =
         , readPredicateTypeDeclaration
         , readNamespaceDecl
         , readDocSectionDecl
+        , fmap SpliceSyntaxDeclaration readSplice
         ]
 
 readSubsumedExpression :: SyntaxExpression -> Parser SyntaxExpression
@@ -458,6 +459,9 @@ readDeclarator =
          simps <- readCommaList readModuleName
          return $ SDImport simps)
 
+readSplice :: Parser SyntaxExpression
+readSplice = readBracketed TokSpliceOpenBrace TokCloseBrace readExpression
+
 readExpression1 :: Parser SyntaxExpression
 readExpression1 =
     readWithSourcePos
@@ -570,6 +574,23 @@ readExpression3 =
                  readWithSourcePos $ do
                      rexpr <- readExpression
                      return $ SEAppQuote rexpr) <|>
+    readWithSourcePos (fmap SESplice readSplice) <|>
+    readWithSourcePos
+        (do
+             sname <- readThis TokSpecialName
+             case sname of
+                 "expression" -> readBracketed TokOpenBrace TokCloseBrace $ fmap SEQuoteExpression readExpression
+                 "scope" -> readBracketed TokOpenBrace TokCloseBrace $ fmap SEQuoteScope $ readLines readDeclaration
+                 _ -> mzero) <|>
+    readWithSourcePos
+        (do
+             readThis TokAt
+             t <- readType3
+             return $ SEQuoteType t) <|>
+    readWithSourcePos
+        (do
+             anchor <- readThis TokAnchor
+             return $ SEQuoteAnchor anchor) <|>
     readWithSourcePos
         (do
              readThis TokUnquote

Pinafore/pinafore-syntax/lib/Pinafore/Syntax/Parse/Token.hs

@@ -81,6 +81,7 @@ data Token t where
     TokCloseBracket :: Token ()
     TokOpenBrace :: Token ()
     TokCloseBrace :: Token ()
+    TokSpliceOpenBrace :: Token ()
     TokString :: Token Text
     TokUnquote :: Token ()
     TokRec :: Token ()
@@ -114,6 +115,7 @@ data Token t where
     TokMap :: Token ()
     TokBackMap :: Token ()
     TokAnchor :: Token Anchor
+    TokSpecialName :: Token Name
     TokAt :: Token ()
     TokOperator :: Token TokenNames
     TokSubtypeOf :: Token ()
@@ -141,6 +143,7 @@ instance TestEquality Token where
     testEquality TokCloseParen TokCloseParen = Just Refl
     testEquality TokOpenBracket TokOpenBracket = Just Refl
     testEquality TokCloseBracket TokCloseBracket = Just Refl
+    testEquality TokSpliceOpenBrace TokSpliceOpenBrace = Just Refl
     testEquality TokOpenBrace TokOpenBrace = Just Refl
     testEquality TokCloseBrace TokCloseBrace = Just Refl
     testEquality TokString TokString = Just Refl
@@ -176,6 +179,7 @@ instance TestEquality Token where
     testEquality TokMap TokMap = Just Refl
     testEquality TokBackMap TokBackMap = Just Refl
     testEquality TokAnchor TokAnchor = Just Refl
+    testEquality TokSpecialName TokSpecialName = Just Refl
     testEquality TokAt TokAt = Just Refl
     testEquality TokOperator TokOperator = Just Refl
     testEquality TokSubtypeOf TokSubtypeOf = Just Refl
@@ -199,6 +203,7 @@ tokenName TokOpenParen = FixedTokenName "("
 tokenName TokCloseParen = FixedTokenName ")"
 tokenName TokOpenBracket = FixedTokenName "["
 tokenName TokCloseBracket = FixedTokenName "]"
+tokenName TokSpliceOpenBrace = FixedTokenName "!{"
 tokenName TokOpenBrace = FixedTokenName "{"
 tokenName TokCloseBrace = FixedTokenName "}"
 tokenName TokString = VarTokenName (\case {}) "quoted string"
@@ -234,6 +239,7 @@ tokenName TokAssign = FixedTokenName "="
 tokenName TokMap = FixedTokenName "=>"
 tokenName TokBackMap = FixedTokenName "<-"
 tokenName TokAnchor = VarTokenName (\case {}) "anchor"
+tokenName TokSpecialName = VarTokenName (\case {}) "special name"
 tokenName TokAt = FixedTokenName "@"
 tokenName TokOperator = VarTokenName (\case {}) "infix"
 tokenName TokSubtypeOf = FixedTokenName "<:"
@@ -446,12 +452,17 @@ readHexAnchor = do
         octets <- fromHex $ filter isHexDigit cs
         decode anchorCodec $ fromList octets
 
+readLowerCaseName :: Parser Name
+readLowerCaseName = do
+    (u, name) <- readName
+    altIf $ not u
+    return name
+
 readImplicitName :: Parser (SomeOf Token)
 readImplicitName =
     try $ do
         readChar '?'
-        (u, name) <- readName
-        altIf $ not u
+        name <- readLowerCaseName
         return $ MkSomeOf TokImplicitName $ MkImplicitName name
 
 readOpToken :: Parser (SomeOf Token)
@@ -473,7 +484,10 @@ readOpToken = do
                  return $ MkSomeOf TokAnchor anchor) <|>
             (do
                  s <- readQuotedString
-                 return $ MkSomeOf TokAnchor $ codeAnchor s)
+                 return $ MkSomeOf TokAnchor $ codeAnchor s) <|>
+            (do
+                 n <- readLowerCaseName
+                 return $ MkSomeOf TokSpecialName n)
         "@" -> return $ MkSomeOf TokAt ()
         "|" -> return $ MkSomeOf TokOr ()
         "&" -> return $ MkSomeOf TokAnd ()

Pinafore/pinafore-syntax/lib/Pinafore/Syntax/Syntax.hs

@@ -112,6 +112,7 @@ data SyntaxDeclaration'
                                  [SyntaxDeclaration]
     | DocSectionSyntaxDeclaration Text
                                   [SyntaxDeclaration]
+    | SpliceSyntaxDeclaration SyntaxExpression
     | DebugSyntaxDeclaration FullNameRef
     deriving (Eq)
 
@@ -319,8 +320,6 @@ data SyntaxExpression'
             FullNameRef
             (Maybe [(Name, SyntaxExpression)])
     | SEImplicitVar ImplicitName
-    | SESpecialForm FullNameRef
-                    (NonEmpty SyntaxAnnotation)
     | SEApply SyntaxExpression
               SyntaxExpression
     | SEAbstract SyntaxCase
@@ -334,6 +333,15 @@ data SyntaxExpression'
     | SEDecl SyntaxDeclarator
              SyntaxExpression
     | SEList [SyntaxExpression]
+    -- macro stuff
+    | SESpecialForm FullNameRef
+                    (NonEmpty SyntaxAnnotation)
+    | SESplice SyntaxExpression
+    | SEQuoteExpression SyntaxExpression
+    | SEQuoteScope [SyntaxDeclaration]
+    | SEQuoteType SyntaxType
+    | SEQuoteAnchor Anchor
+    -- debug
     | SEDebug Text
               SyntaxExpression
     deriving (Eq)