Merge #180

180: Simplify and openapi-ify /api/program r=brprice a=brprice

Simplify the return types from `/api/program`, and port to openapi3.
We drastically simplify by returning a rose tree where each node is labeled with
an ID and a textual label, instead of a full AST.

The rationale is that a frontend is mostly concerned with rendering and does not
need to know about the complexity of the full AST. This initial iteration is obviously
oversimplified and is expected to expand in the future.

Co-authored-by: Ben Price <[email protected]>

primer-service/src/Primer/OpenAPI.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Primer.OpenAPI (
@@ -6,8 +7,12 @@ module Primer.OpenAPI (
 ) where
 
 import Data.OpenApi (ToSchema)
+import Data.Text (Text)
+import Primer.API (Def, Prog, Tree)
 import Primer.App (InitialApp)
+import Primer.Core (ID (..))
 import Primer.Database (Session, SessionName)
+import Primer.Name (Name)
 
 -- $orphanInstances
 --
@@ -19,3 +24,14 @@ import Primer.Database (Session, SessionName)
 instance ToSchema SessionName
 instance ToSchema Session
 instance ToSchema InitialApp
+
+-- We need to GND the ID instance to match its To/FromJSON instances
+deriving newtype instance ToSchema ID
+
+-- We can't GND derive for Name as it is an opaque type
+-- But the JSON instance is done by GND, so we must match here...
+-- This instance works because the parameter has a phantom role!
+deriving via Text instance (ToSchema Name)
+instance ToSchema Tree
+instance ToSchema Def
+instance ToSchema Prog

primer-service/src/Primer/Server.hs

@@ -47,6 +47,7 @@ import Primer.API (
   renameSession,
   variablesInScope,
  )
+import qualified Primer.API as API
 import Primer.Action (
   Action (Move),
   ActionError (TypeError),
@@ -162,7 +163,11 @@ type PrimerOpenAPI =
   :<|> QueryFlag "inMemory" :> "sessions" :>
     PaginationParams :>
     Summary "List sessions" :>
-    OpId "getSessionList" Get '[JSON] (Paginated Session))
+    OpId "getSessionList" Get '[JSON] (Paginated Session)
+
+    -- The rest of the API is scoped to a particular session
+  :<|> QueryParam' '[Required, Strict] "session" SessionId :> SOpenAPI
+  )
 
 type PrimerLegacyAPI =
   "api" :> (
@@ -193,15 +198,19 @@ type PrimerLegacyAPI =
   :<|> Raw
 
 -- | The session-specific bits of the api
-type SAPI = (
-
+type SOpenAPI = (
     -- GET /api/program
     --   Get the current program state
-    "program" :> Get '[JSON] (Result ProgError Prog)
+    "program" :> Get '[JSON] API.Prog
+  )
+
 
+-- | The session-specific bits of the api
+-- (legacy version)
+type SAPI = (
     -- GET /api/session-name
     --   Get the current session name.
-  :<|> "session-name" :> Get '[JSON] Text
+       "session-name" :> Get '[JSON] Text
 
     -- PUT /api/session-name
     --   Attempt to set the current session name. Returns the new
@@ -370,13 +379,13 @@ primerServer = openAPIServer :<|> legacyServer
   where
     openAPIServer =
       newSession
-        :<|> \b p -> pagedDefaultClamp 100 p $ listSessions b
+        :<|> (\b p -> pagedDefaultClamp 100 p $ listSessions b)
+        :<|> getProgram
     legacyServer =
       ( copySession
           :<|> getVersion
           :<|> ( \sid ->
-                  getProgram sid
-                    :<|> getSessionName sid
+                  getSessionName sid
                     :<|> renameSession sid
                     :<|> edit sid
                     :<|> (variablesInScope sid :<|> generateNames sid)

primer/primer.cabal

@@ -96,6 +96,7 @@ test-suite primer-test
     Tests.Action.Capture
     Tests.Action.Prog
     Tests.AlphaEquality
+    Tests.API
     Tests.Database
     Tests.Eval
     Tests.EvalFull

primer/src/Primer/API.hs

@@ -19,6 +19,9 @@ module Primer.API (
   copySession,
   listSessions,
   getVersion,
+  Tree,
+  Prog,
+  Def,
   getProgram,
   getSessionName,
   renameSession,
@@ -28,6 +31,9 @@ module Primer.API (
   evalStep,
   evalFull,
   flushSessions,
+  -- viewTree*: only exported for testing
+  viewTreeType,
+  viewTreeExpr,
 ) where
 
 import Foreword
@@ -41,6 +47,10 @@ import Control.Concurrent.STM (
   writeTBQueue,
  )
 import Control.Monad.Catch (MonadThrow, throwM)
+import Data.Aeson (ToJSON)
+import Data.Data (showConstr, toConstr)
+import qualified Data.Generics.Uniplate.Data as U
+import qualified Data.Map as Map
 import qualified ListT (toList)
 import Primer.App (
   App,
@@ -51,7 +61,6 @@ import Primer.App (
   EvalResp (..),
   InitialApp,
   MutationRequest,
-  Prog,
   ProgError,
   QueryAppM,
   Question (..),
@@ -62,13 +71,25 @@ import Primer.App (
   handleMutationRequest,
   handleQuestion,
   initialApp,
+  progDefs,
+  progTypes,
   runEditAppM,
   runQueryAppM,
  )
+import qualified Primer.App as App
 import Primer.Core (
+  Expr,
+  Expr' (APP, Ann, GlobalVar, LetType, Letrec),
   ID,
   Kind,
-  Type',
+  Type,
+  Type' (TForall),
+  defExpr,
+  defID,
+  defName,
+  defType,
+  getID,
+  typeDefName,
  )
 import Primer.Database (
   OffsetLimit,
@@ -97,7 +118,7 @@ import qualified Primer.Database as Database (
     Success
   ),
  )
-import Primer.Name (Name)
+import Primer.Name (Name, unName)
 import qualified StmContainers.Map as StmMap
 
 data Env = Env
@@ -256,10 +277,97 @@ liftEditAppM h sid = withSession' sid (EditApp $ runEditAppM h)
 liftQueryAppM :: (MonadIO m, MonadThrow m) => QueryAppM a -> SessionId -> PrimerM m (Result ProgError a)
 liftQueryAppM h sid = withSession' sid (QueryApp $ runQueryAppM h)
 
-getProgram :: (MonadIO m, MonadThrow m) => SessionId -> PrimerM m (Result ProgError Prog)
-getProgram = liftQueryAppM handleGetProgramRequest
+getProgram :: (MonadIO m, MonadThrow m) => SessionId -> PrimerM m Prog
+getProgram sid = withSession' sid $ QueryApp $ viewProg . handleGetProgramRequest
+
+-- | A frontend will be mostly concerned with rendering, and does not need the
+-- full complexity of our AST for that task. 'Tree' is a simplified view with
+-- just enough information to render nicely.
+-- (NB: currently this is just a first draft, and is expected to evolve.)
+data Tree = Tree
+  { nodeId :: ID
+  , label :: Text
+  , childTrees :: [Tree]
+  }
+  deriving (Show, Eq, Generic)
+
+instance ToJSON Tree
+
+-- | This type is the API's view of a 'App.Prog'
+-- (this is expected to evolve as we flesh out the API)
+data Prog = Prog
+  { types :: [Name]
+  , -- We don't use Map ID Def, as the JSON encoding would be as an object,
+    -- where keys are IDs converted to strings and we have no nice way of
+    -- saying "all the keys of this object should parse as numbers". Similarly,
+    -- it is rather redundant as each Def carries a defID field (which is
+    -- encoded as a number), and it is difficult to enforce that "the keys of
+    -- this object match the defID field of the corresponding value".
+    defs :: [Def]
+  }
+  deriving (Generic)
+
+instance ToJSON Prog
+
+-- | This type is the api's view of a 'Primer.Core.Def'
+-- (this is expected to evolve as we flesh out the API)
+data Def = Def
+  { id :: ID
+  , name :: Name
+  , type_ :: Tree
+  , term :: Tree
+  }
+  deriving (Generic)
+
+instance ToJSON Def
+
+viewProg :: App.Prog -> Prog
+viewProg p =
+  Prog
+    { types = typeDefName <$> progTypes p
+    , defs =
+        ( \d ->
+            Def
+              { id = defID d
+              , name = defName d
+              , type_ = viewTreeType $ defType d
+              , term = viewTreeExpr $ defExpr d
+              }
+        )
+          <$> Map.elems (progDefs p)
+    }
+
+-- | A simple method to extract 'Tree's from 'Expr's. This is injective.
+-- Currently it is designed to be simple and just enough to enable
+-- experimenting with rendering on the frontend.
+--
+-- It is expected to evolve in the future.
+viewTreeExpr :: Expr -> Tree
+viewTreeExpr = U.para $ \e exprChildren ->
+  let c = toS $ showConstr $ toConstr e
+      n = case e of
+        GlobalVar _ i -> c <> " " <> show i
+        _ -> unwords $ c : map unName (U.childrenBi e)
+      -- add info about type children
+      allChildren = case e of
+        Ann _ _ ty -> exprChildren ++ [viewTreeType ty]
+        APP _ _ ty -> exprChildren ++ [viewTreeType ty]
+        LetType _ _ ty _ -> viewTreeType ty : exprChildren
+        Letrec _ _ _ ty _ -> let (h, t) = splitAt 1 exprChildren in h ++ viewTreeType ty : t
+        -- otherwise, no type children
+        _ -> exprChildren
+   in Tree (getID e) n allChildren
+
+-- | Similar to 'viewTreeExpr', but for 'Type's
+viewTreeType :: Type -> Tree
+viewTreeType = U.para $ \e allChildren ->
+  let c = toS $ showConstr $ toConstr e
+      n = case e of
+        TForall _ m k _ -> c <> " " <> unName m <> ":" <> show k
+        _ -> unwords $ c : map unName (U.childrenBi e)
+   in Tree (getID e) n allChildren
 
-edit :: (MonadIO m, MonadThrow m) => SessionId -> MutationRequest -> PrimerM m (Result ProgError Prog)
+edit :: (MonadIO m, MonadThrow m) => SessionId -> MutationRequest -> PrimerM m (Result ProgError App.Prog)
 edit sid req = liftEditAppM (handleMutationRequest req) sid
 
 variablesInScope :: (MonadIO m, MonadThrow m) => SessionId -> (ID, ID) -> PrimerM m (Result ProgError (([(Name, Kind)], [(Name, Type' ())]), [(ID, Name, Type' ())]))

primer/src/Primer/App.hs

@@ -292,7 +292,7 @@ focusNode prog defid nodeid =
             Just x -> pure x
 
 -- | Handle a request to retrieve the current program
-handleGetProgramRequest :: MonadQueryApp m => m Prog
+handleGetProgramRequest :: MonadReader App m => m Prog
 handleGetProgramRequest = asks appProg
 
 -- | Handle a request to mutate the app state

primer/src/Primer/Core.hs

@@ -64,11 +64,8 @@ newtype ID = ID {unID :: Int}
   -- The Ord and Enum instances are useful for tests but we may remove them in
   -- future, so don't use them in app code.
   deriving newtype (Show, Num, Ord, Enum)
-  deriving (FromJSON, ToJSON) via VJSON ID
-
-instance ToJSONKey ID
-
-instance FromJSONKey ID
+  deriving newtype (FromJSON, ToJSON)
+  deriving newtype (ToJSONKey, FromJSONKey)
 
 data Meta a = Meta ID a (Maybe Value)
   deriving (Generic, Eq, Show, Data, Functor)

primer/src/Primer/Name.hs

@@ -23,7 +23,7 @@ import Primer.JSON
 newtype Name = Name {unName :: Text}
   deriving (Eq, Ord, Generic, Data)
   deriving newtype (Show, IsString)
-  deriving (FromJSON, ToJSON) via VJSON Name
+  deriving newtype (FromJSON, ToJSON)
 
 -- | Construct a name from a Text. This is called unsafe because there are no
 -- guarantees about whether the name refers to anything that is in scope.