Interpretation (#298): fix tests

AshleyYakeley · Oct 15, 2024 · ab64dfb · ab64dfb
1 parent 0846ae6
commit ab64dfb
Show file tree

Hide file tree

Showing 8 changed files with 113 additions and 71 deletions.
diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Interpret/Expression.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Interpret/Expression.hs
@@ -15,12 +15,12 @@ import Pinafore.Language.Expression
 import Pinafore.Language.If
 import Pinafore.Language.Interpret.AppNotation
 import Pinafore.Language.Interpret.FreeVars
+import Pinafore.Language.Interpret.SpecialForm
 import Pinafore.Language.Interpret.Type
 import Pinafore.Language.Interpret.TypeDecl
 import Pinafore.Language.Interpret.Value
 import Pinafore.Language.Interpreter
 import Pinafore.Language.Library.Types
-import Pinafore.Language.SpecialForm
 import Pinafore.Language.Type
 import Pinafore.Language.Var
 import Pinafore.Language.VarID
@@ -377,44 +377,6 @@ interpretConstructor (SLNamedConstructor v mvals) = do
 interpretConstructor SLPair = return $ qConst ((,) :: A -> B -> (A, B))
 interpretConstructor SLUnit = return $ qConst ()
 
-specialFormArg :: QAnnotation t -> SyntaxAnnotation -> ComposeInner Maybe QInterpreter t
-specialFormArg AnnotAnchor (SAAnchor anchor) = return anchor
-specialFormArg AnnotNonpolarType (SAType st) = lift $ interpretNonpolarType st
-specialFormArg AnnotPositiveType (SAType st) = lift $ interpretType @'Positive st
-specialFormArg AnnotNegativeType (SAType st) = lift $ interpretType @'Negative st
-specialFormArg _ _ = liftInner Nothing
-
-specialFormArgs :: ListType QAnnotation lt -> [SyntaxAnnotation] -> ComposeInner Maybe QInterpreter (ListProduct lt)
-specialFormArgs NilListType [] = return ()
-specialFormArgs (ConsListType t tt) (a:aa) = do
-    v <- specialFormArg t a
-    vv <- specialFormArgs tt aa
-    return (v, vv)
-specialFormArgs _ _ = liftInner Nothing
-
-showSA :: SyntaxAnnotation -> NamedText
-showSA (SAType _) = "type"
-showSA (SAAnchor _) = "anchor"
-
-showAnnotation :: QAnnotation a -> NamedText
-showAnnotation AnnotAnchor = "anchor"
-showAnnotation AnnotNonpolarType = "type"
-showAnnotation AnnotPositiveType = "type"
-showAnnotation AnnotNegativeType = "type"
-
-interpretSpecialForm :: FullNameRef -> NonEmpty SyntaxAnnotation -> QInterpreter QExpression
-interpretSpecialForm name annotations = do
-    MkQSpecialForm largs val <- lookupSpecialForm name
-    margs <- unComposeInner $ specialFormArgs largs $ toList annotations
-    case margs of
-        Just args -> val args
-        Nothing ->
-            throw $
-            SpecialFormWrongAnnotationsError
-                name
-                (listTypeToList showAnnotation largs)
-                (fmap showSA $ toList annotations)
-
 interpretConstant :: SyntaxConstant -> QInterpreter QExpression
 interpretConstant SCIfThenElse = return $ qConst qifthenelse
 interpretConstant (SCConstructor lit) = interpretConstructor lit
@@ -558,7 +520,7 @@ interpretExpression' (SEVar _ name mvals) = do
     marglist <- for mvals interpretRecordArgList
     interpretValue name marglist
 interpretExpression' (SEImplicitVar name) = return $ qVar $ ImplicitVarID name
-interpretExpression' (SESpecialForm name annots) = interpretSpecialForm name annots
+interpretExpression' (SESpecialForm name annots) = interpretSpecialForm name Nothing $ toList annots
 interpretExpression' (SEAppQuote sexpr) = appNotationQuote $ interpretExpression sexpr
 interpretExpression' (SEAppUnquote sexpr) = appNotationUnquote $ interpretExpression sexpr
 interpretExpression' (SEList sexprs) = do

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Interpret/SpecialForm.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Interpret/SpecialForm.hs
@@ -0,0 +1,48 @@
+module Pinafore.Language.Interpret.SpecialForm
+    ( interpretSpecialForm
+    ) where
+
+import Import
+import Pinafore.Language.Error
+import Pinafore.Language.Interpret.Type
+import Pinafore.Language.Interpreter
+import Pinafore.Language.SpecialForm
+import Pinafore.Language.Type
+
+specialFormArg :: QAnnotation t -> SyntaxAnnotation -> ComposeInner Maybe QInterpreter t
+specialFormArg AnnotAnchor (SAAnchor anchor) = return anchor
+specialFormArg AnnotNonpolarType (SAType st) = lift $ interpretNonpolarType st
+specialFormArg AnnotPositiveType (SAType st) = lift $ interpretType @'Positive st
+specialFormArg AnnotNegativeType (SAType st) = lift $ interpretType @'Negative st
+specialFormArg _ _ = liftInner Nothing
+
+specialFormArgs :: ListType QAnnotation lt -> [SyntaxAnnotation] -> ComposeInner Maybe QInterpreter (ListProduct lt)
+specialFormArgs NilListType [] = return ()
+specialFormArgs (ConsListType t tt) (a:aa) = do
+    v <- specialFormArg t a
+    vv <- specialFormArgs tt aa
+    return (v, vv)
+specialFormArgs _ _ = liftInner Nothing
+
+showSA :: SyntaxAnnotation -> NamedText
+showSA (SAType _) = "type"
+showSA (SAAnchor _) = "anchor"
+
+showAnnotation :: QAnnotation a -> NamedText
+showAnnotation AnnotAnchor = "anchor"
+showAnnotation AnnotNonpolarType = "type"
+showAnnotation AnnotPositiveType = "type"
+showAnnotation AnnotNegativeType = "type"
+
+interpretSpecialForm :: FullNameRef -> Maybe QSpecialForm -> [SyntaxAnnotation] -> QInterpreter QExpression
+interpretSpecialForm name msf annotations = do
+    MkQSpecialForm largs val <-
+        case msf of
+            Just sf -> return sf
+            Nothing -> lookupSpecialForm name
+    margs <- unComposeInner $ specialFormArgs largs annotations
+    case margs of
+        Just args -> val args
+        Nothing ->
+            throw $
+            SpecialFormWrongAnnotationsError name (listTypeToList showAnnotation largs) (fmap showSA annotations)
diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Interpret/Value.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Interpret/Value.hs
@@ -5,6 +5,7 @@ module Pinafore.Language.Interpret.Value
 import Import
 import Pinafore.Language.Error
 import Pinafore.Language.Expression
+import Pinafore.Language.Interpret.SpecialForm
 import Pinafore.Language.Interpreter
 import Pinafore.Language.Type
 import Pinafore.Language.VarID
@@ -62,6 +63,7 @@ interpretValueWithDefault name margmap mdefexpr = do
         (Nothing, Just _) -> throw $ LookupNotDefinedError name
         (Just (ValueBoundValue _), Just _) -> throw $ LookupNotRecordConstructorError name
         (Just (RecordBoundValue rv), _) -> interpretRecordValue rv margmap
+        (Just (SpecialFormBoundValue sf), _) -> interpretSpecialForm name (Just sf) []
 
 interpretValue :: FullNameRef -> Maybe [(Name, QExpression)] -> QInterpreter QExpression
 interpretValue name margmap =

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Interpreter/Lookup.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Interpreter/Lookup.hs
@@ -79,6 +79,7 @@ lookupSpecialForm = lookupSelector specialFormBindingSelector
 data QBoundValue
     = ValueBoundValue QExpression
     | RecordBoundValue QRecordValue
+    | SpecialFormBoundValue QSpecialForm
 
 lookupRecord :: FullNameRef -> QInterpreter QRecordValue
 lookupRecord = lookupSelector recordValueBindingSelector
@@ -90,6 +91,7 @@ getBoundValue =
         PatternConstructorBinding exp _ -> Just $ ValueBoundValue exp
         RecordValueBinding rv -> Just $ RecordBoundValue rv
         RecordConstructorBinding rc -> Just $ RecordBoundValue $ recordConstructorToValue rc
+        SpecialFormBinding sf -> Just $ SpecialFormBoundValue sf
         _ -> Nothing
 
 lookupValue :: FullNameRef -> QInterpreter QBoundValue

diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Library/Pinafore.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Library/Pinafore.hs
@@ -96,27 +96,47 @@ pinaforeLibSection =
     pure $
     namespaceBDS
         "Pinafore"
-        [ typeBDS "Context" "" (qSomeGroundType @_ @QContext) []
-        , namespaceBDS
+        [ headingBDS
               "Context"
-              [specialFormBDS "this" "The context at this point in source." [] "Context.Pinafore" thisContext]
-        , typeBDS "Interpreter" "" (qSomeGroundType @_ @QInterpreter) []
-        , namespaceBDS "Interpreter" $ monadEntries @Interpreter <> [valBDS "run" "" langRunInterpreter]
-        , typeBDS "Type" "" (qSomeGroundType @_ @LangType) []
-        , specialFormBDS "const.Type" "" ["@A"] "Type.Pinafore A" $
-          MkQSpecialForm (ConsListType AnnotNonpolarType NilListType) $ \(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 return $ constSealedExpression $ MkSomeOf stype sval
-        , hasSubtypeRelationBDS @(LangType '( P, Q)) @Showable Verify "" $ functionToShim "show" textShowable
-        , namespaceBDS "Type" [valBDS "unify" "Unify two types." langUnifyTypes]
-        , typeBDS "Value" "" (qSomeGroundType @_ @LangValue) []
-        , namespaceBDS
+              ""
+              [ typeBDS "Context" "" (qSomeGroundType @_ @QContext) []
+              , namespaceBDS
+                    "Context"
+                    [specialFormBDS "this" "The context at this point in source." [] "Context.Pinafore" thisContext]
+              ]
+        , headingBDS
+              "Interpreter"
+              ""
+              [ typeBDS "Interpreter" "" (qSomeGroundType @_ @QInterpreter) []
+              , namespaceBDS "Interpreter" $ monadEntries @Interpreter <> [valBDS "run" "" langRunInterpreter]
+              ]
+        , headingBDS
+              "Type"
+              ""
+              [ typeBDS "Type" "" (qSomeGroundType @_ @LangType) []
+              , specialFormBDS "const.Type" "" ["@A"] "Type.Pinafore A" $
+                MkQSpecialForm (ConsListType AnnotNonpolarType NilListType) $ \(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 return $ constSealedExpression $ MkSomeOf stype sval
+              , hasSubtypeRelationBDS @(LangType '( P, Q)) @Showable Verify "" $ functionToShim "show" textShowable
+              , namespaceBDS "Type" [valBDS "unify" "Unify two types." langUnifyTypes]
+              ]
+        , headingBDS
               "Value"
-              [ valBDS "mk" "" mkLangValue
-              , valBDS "unify" "Unify type with value." langUnifyValue
-              , valBDS "interpret" "Interpret Pinafore source." interpretToValue
+              ""
+              [ typeBDS "Value" "" (qSomeGroundType @_ @LangValue) []
+              , namespaceBDS
+                    "Value"
+                    [ valBDS "mk" "" mkLangValue
+                    , valBDS "unify" "Unify type with value." langUnifyValue
+                    , valBDS "interpret" "Interpret Pinafore source." interpretToValue
+                    ]
               ]
         ]
diff --git a/Pinafore/pinafore-language/package.yaml b/Pinafore/pinafore-language/package.yaml
@@ -80,6 +80,7 @@ library:
       - Pinafore.Language.Type.DynamicSupertype
       - Pinafore.Language.Type
       - Pinafore.Language.Interpret.FreeVars
+      - Pinafore.Language.Interpret.SpecialForm
       - Pinafore.Language.Interpret.Value
       - Pinafore.Language.Interpret.AppNotation
       - Pinafore.Language.Interpret.Type

diff --git a/Pinafore/pinafore-language/pinafore-language.cabal b/Pinafore/pinafore-language/pinafore-language.cabal
@@ -70,6 +70,7 @@ library
       Pinafore.Language.Type.DynamicSupertype
       Pinafore.Language.Type
       Pinafore.Language.Interpret.FreeVars
+      Pinafore.Language.Interpret.SpecialForm
       Pinafore.Language.Interpret.Value
       Pinafore.Language.Interpret.AppNotation
       Pinafore.Language.Interpret.Type

diff --git a/Pinafore/pinafore-language/test/Test/Entity.hs b/Pinafore/pinafore-language/test/Test/Entity.hs
@@ -1755,23 +1755,29 @@ testEntity =
               , "testaction = fn expected, action => do {found <- action; testeq expected found}"
               , "testFailure = fn action => do {found <- action; found >- fn {Failure _ => pass; Success _ => fail \"not Failure\"}}"
               ] $
-          tWith ["Eval"] $
+          tWith ["Pinafore"] $
+          tDecls
+              [ "evaluate = fn t, text => run.Interpreter this.Context $ do.Interpreter { v <- interpret.Value text; unify.Value t v }"
+              ] $
           tGroup
               "evaluate"
-              [ testExpectSuccess "testaction (Success True) $ evaluate @Boolean \"True\""
-              , testExpectSuccess "testaction (Success 5) $ evaluate @Integer \"5\""
-              , testExpectSuccess "testaction (Success 5) $ evaluate @Integer \"let {x = 5} x\""
+              [ testExpectSuccess "pass"
+              , testExpectSuccess "testaction (Success True) $ evaluate (const.Type @Boolean) \"True\""
+              , testExpectSuccess "testaction (Success 5) $ evaluate (const.Type @Integer) \"5\""
+              , testExpectSuccess "testaction (Success 5) $ evaluate (const.Type @Integer) \"let {x = 5} x\""
+              , testExpectSuccess
+                    "do {ar <- evaluate (const.Type @(Integer -> Integer)) \"fn x => x +.Integer 1\"; ar >- fn {Failure err => fail err; Success f => testeq 8 $ f 7}}"
+              , testExpectSuccess
+                    "testaction (Failure \"<evaluate>:1:1: syntax: expecting: expression\") $ evaluate (const.Type @Integer) \"\""
               , testExpectSuccess
-                    "do {ar <- evaluate @(Integer -> Integer) \"fn x => x +.Integer 1\"; ar >- fn {Failure err => fail err; Success f => testeq 8 $ f 7}}"
+                    "testaction (Failure \"<evaluate>:1:1: undefined: f: a\") $ evaluate (const.Type @Integer) \"f\""
+              , testExpectSuccess "testFailure $ evaluate (const.Type @Integer) \"\\\"hello\\\"\""
               , testExpectSuccess
-                    "testaction (Failure \"<evaluate>:1:1: syntax: expecting: expression\") $ evaluate @Integer \"\""
-              , testExpectSuccess "testaction (Failure \"<evaluate>:1:1: undefined: f: a\") $ evaluate @Integer \"f\""
-              , testExpectSuccess "testFailure $ evaluate @Integer \"\\\"hello\\\"\""
+                    "do {r <- newMem.WholeModel; ar <- evaluate (const.Type @(WholeModel Integer -> Action Unit)) \"fn r => r :=.WholeModel 45\"; runresult ar r; a <- get r; testeq 45 a;}"
               , testExpectSuccess
-                    "do {r <- newMem.WholeModel; ar <- evaluate @(WholeModel Integer -> Action Unit) \"fn r => r :=.WholeModel 45\"; runresult ar r; a <- get r; testeq 45 a;}"
-              , testExpectSuccess "testaction 569 $ evaluate @(a -> a) \"fn x => x\" >>= fn Success f => pure $ f 569"
+                    "testaction 569 $ evaluate (const.Type @(a -> a)) \"fn x => x\" >>= fn Success f => pure $ f 569"
               , testExpectSuccess
-                    "testaction 570 $  evaluate @(Integer -> Integer) \"fn x => x\" >>= fn Success f => pure $ f 570"
+                    "testaction 570 $ evaluate (const.Type @(Integer -> Integer)) \"fn x => x\" >>= fn Success f => pure $ f 570"
               ]
         , tGroup
               "text-sort"