First iteration of tree api

primer-service/src/Primer/OpenAPI.hs

@@ -6,8 +6,11 @@ module Primer.OpenAPI (
 ) where
 
 import Data.OpenApi (ToSchema)
+import Primer.API (APIDef, APIProg, Tree)
 import Primer.App (InitialApp)
+import Primer.Core (ID)
 import Primer.Database (Session, SessionName)
+import Primer.Name (Name)
 
 -- $orphanInstances
 --
@@ -19,3 +22,8 @@ import Primer.Database (Session, SessionName)
 instance ToSchema SessionName
 instance ToSchema Session
 instance ToSchema InitialApp
+instance ToSchema ID
+instance ToSchema Name
+instance ToSchema Tree
+instance ToSchema APIDef
+instance ToSchema APIProg

primer-service/src/Primer/Server.hs

@@ -31,6 +31,7 @@ import Network.Wai.Handler.Warp (
 import qualified Network.Wai.Handler.Warp as Warp (runSettings)
 import Optics ((%), (.~), (?~))
 import Primer.API (
+  APIProg,
   Env (..),
   PrimerErr (..),
   PrimerM,
@@ -161,7 +162,11 @@ type PrimerOpenAPI =
     --   sessions that the caller is authorized to see.
   :<|> QueryFlag "inMemory" :> "sessions" :>
     Summary "List sessions" :>
-    OpId "getSessionList" Get '[JSON] [Session])
+    OpId "getSessionList" Get '[JSON] [Session]
+
+    -- The rest of the API is scoped to a particular session
+  :<|> QueryParam' '[Required, Strict] "session" SessionId :> SOpenAPI
+  )
 
 type PrimerLegacyAPI =
   "api" :> (
@@ -192,15 +197,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] Prog
+    "program" :> Get '[JSON] APIProg
+  )
+
 
+-- | 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
@@ -367,13 +376,15 @@ hoistPrimer e = hoistServer primerApi nt primerServer
 primerServer :: ServerT PrimerAPI (PrimerM IO)
 primerServer = openAPIServer :<|> legacyServer
   where
-    openAPIServer = newSession :<|> listSessions
+    openAPIServer =
+      newSession
+        :<|> listSessions
+        :<|> getProgram
     legacyServer =
       ( copySession
           :<|> getVersion
           :<|> ( \sid ->
-                  getProgram sid
-                    :<|> getSessionName sid
+                  getSessionName sid
                     :<|> renameSession sid
                     :<|> edit sid
                     :<|> (variablesInScope sid :<|> generateNames sid)

primer/primer.cabal

@@ -95,6 +95,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,
+  APIProg,
+  APIDef,
   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,7 @@ import Primer.App (
   EvalResp (..),
   InitialApp,
   MutationRequest,
-  Prog,
+  Prog (progDefs, progTypes),
   ProgError,
   QueryAppM,
   Question (..),
@@ -66,9 +76,17 @@ import Primer.App (
   runQueryAppM,
  )
 import Primer.Core (
+  Expr,
+  Expr' (APP, Ann, Con, LetType, Letrec, Var),
   ID,
   Kind,
-  Type',
+  Type,
+  Type' (TCon, TVar),
+  defExpr,
+  defName,
+  defType,
+  getID,
+  typeDefName,
  )
 import Primer.Database (
   Session (Session),
@@ -94,7 +112,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
@@ -251,8 +269,97 @@ liftQueryAppM h sid = withSession' sid (QueryApp $ runQueryAppM h)
 -- REVIEW: do we want to keep the error wrapper?
 --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 handleGetProgramRequest
+getProgram :: (MonadIO m, MonadThrow m) => SessionId -> PrimerM m APIProg
+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 -- REVIEW: here, and in APIDef we maybe want a raw Int, as IDs serialise as '{unID: 5}'
+  , label :: Text
+  , children :: [Tree]
+  }
+  deriving (Show, Eq, Generic)
+
+instance ToJSON Tree
+
+-- REVIEW: naming of APIProg
+
+-- | This type is the api's view of a 'Prog'
+-- (this is expected to evolve as we flesh out the API)
+data APIProg = APIProg
+  { types :: [Name]
+  , -- We don't use Map ID APIDef, as the openapi instance of map is broken (goes
+    -- via list of pairs, and it openapi3 cannot represent hetrogenous tuples!)
+    defs :: [APIDef]
+  }
+  deriving (Generic)
+
+instance ToJSON APIProg
+
+-- | This type is the api's view of a 'Def'
+-- (this is expected to evolve as we flesh out the API)
+data APIDef = APIDef
+  { id :: ID
+  , name :: Name
+  , _type :: Tree
+  , term :: Tree
+  -- type and term: REVIEW: naming
+  -- (iirc, 'type' is a keyword both in Haskell and TypeScript)
+  }
+  deriving (Generic)
+
+instance ToJSON APIDef
+
+viewProg :: Prog -> APIProg
+viewProg p =
+  APIProg
+    { types = typeDefName <$> progTypes p
+    , defs =
+        ( \(i, d) ->
+            APIDef
+              { id = i
+              , name = defName d
+              , _type = viewTreeType $ defType d
+              , term = viewTreeExpr $ defExpr d
+              }
+        )
+          <$> Map.toList (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
+        Con _ n' -> c <> " " <> unName n'
+        Var _ n' -> c <> " " <> unName n'
+        _ -> c
+      -- 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
+        TCon _ n' -> c <> " " <> unName n'
+        TVar _ n' -> c <> " " <> unName n'
+        _ -> c
+   in Tree (getID e) n allChildren
 
 edit :: (MonadIO m, MonadThrow m) => SessionId -> MutationRequest -> PrimerM m (Result ProgError Prog)
 edit sid req = liftEditAppM (handleMutationRequest req) sid

primer/test/Tests/API.hs

@@ -0,0 +1,21 @@
+module Tests.API where
+
+import Foreword
+
+import Gen.Core.Raw (evalExprGen, genExpr, genType)
+import Hedgehog
+import Primer.API (viewTreeExpr, viewTreeType)
+
+hprop_viewTreeExpr :: Property
+hprop_viewTreeExpr = property $ do
+  e1 <- forAll $ evalExprGen 0 genExpr
+  e2 <- forAll $ evalExprGen 0 genExpr
+  when (e1 == e2) discard
+  viewTreeExpr e1 /== viewTreeExpr e2
+
+hprop_viewTreeType :: Property
+hprop_viewTreeType = property $ do
+  t1 <- forAll $ evalExprGen 0 genType
+  t2 <- forAll $ evalExprGen 0 genType
+  when (t1 == t2) discard
+  viewTreeType t1 /== viewTreeType t2