feat(primer-miso): Select from multiple definitions (#1311)

primer-miso/src/Primer/Miso.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE NoFieldSelectors #-}
 
 module Primer.Miso (start) where
@@ -14,6 +15,7 @@ import Data.Aeson (FromJSON, ToJSON)
 import Data.Data (Data (..))
 import Data.Default qualified as Default
 import Data.Generics.Uniplate.Data (children)
+import Data.Map ((!?))
 import Data.Map qualified as Map
 import Data.Tree (Tree)
 import Data.Tree qualified as Tree
@@ -36,6 +38,7 @@ import Miso (
   JSM,
   LogLevel (Off),
   View,
+  button_,
   defaultEvents,
   div_,
   fromTransition,
@@ -45,14 +48,15 @@ import Miso (
   style_,
   text,
  )
-import Optics (lensVL, over, to, (%), (.~), (^.), (^..))
+import Optics (lensVL, over, to, (%), (.~), (^.), (^..), _Just)
 import Optics.State.Operators ((?=))
 import Primer.App (
   NodeSelection (NodeSelection),
   NodeType (BodyNode, SigNode),
   Prog (progImports),
   newProg,
  )
+import Primer.App.Base (DefSelection (..))
 import Primer.Core (
   Bind' (Bind),
   CaseBranch' (CaseBranch),
@@ -72,6 +76,7 @@ import Primer.Core (
     PrimCon,
     Var
   ),
+  GVarName,
   GlobalName (baseName, qualifiedModule),
   Kind' (..),
   LocalName (unLocalName),
@@ -80,14 +85,16 @@ import Primer.Core (
   PrimCon (..),
   TmVarRef (GlobalVarRef, LocalVarRef),
   Type' (..),
+  globalNamePretty,
   mkSimpleModuleName,
+  qualifyName,
   typesInExpr,
   _exprMetaLens,
   _kindMetaLens,
   _typeMetaLens,
  )
 import Primer.Core qualified as Primer
-import Primer.Def (Def (..))
+import Primer.Core.Utils (forgetTypeMetadata)
 import Primer.JSON (CustomJSON (..), PrimerJSON)
 import Primer.Miso.Colors (
   blackPrimary,
@@ -112,6 +119,8 @@ import Primer.Miso.Layout (
  )
 import Primer.Miso.Util (
   ASTDefT (expr, sig),
+  DefSelectionT,
+  ModuleT (..),
   NodeSelectionT,
   TermMeta',
   bindingsInExpr,
@@ -122,14 +131,14 @@ import Primer.Miso.Util (
   tcBasicProg,
   typeBindingsInExpr,
  )
-import Primer.Module (Module (moduleDefs, moduleName))
+import Primer.Module (Module (moduleName))
 import Primer.Name (Name, unName)
 
 start :: JSM ()
 start =
   startAppWithSavedState
     App
-      { model = Model{def = mapDef, selection = Nothing}
+      { model = Model{module_, selection = Nothing}
       , update = updateModel
       , view = viewModel
       , subs = []
@@ -139,57 +148,72 @@ start =
       , logLevel = Off
       }
   where
-    -- TODO we display a single hardcoded expression, for the sake of demonstration
-    mapDef =
-      either (error . ("Prelude.map failed to typecheck: " <>) . show) identity
+    -- TODO we hardcode Prelude as the active module, for the sake of demonstration
+    module_ =
+      either (error . ("Prelude failed to typecheck: " <>) . show) identity
         . tcBasicProg p
-        $ fromMaybe (error "prog doesn't contain Prelude.map") do
-          m <- find ((== mkSimpleModuleName "Prelude") . moduleName) $ progImports p
-          DefAST d <- Map.lookup "map" $ moduleDefs m
-          pure d
+        . fromMaybe (error "prog doesn't contain Prelude")
+        . find ((== mkSimpleModuleName "Prelude") . moduleName)
+        $ progImports p
       where
         (p, _, _) = newProg
 
 data Model = Model
-  { def :: ASTDefT -- We typecheck everything up front so that we can use `ExprT`, guaranteeing existence of metadata.
-  , selection :: Maybe NodeSelectionT -- TODO once we move beyond one-tree prototype, we'll need to generalise this
+  { module_ :: ModuleT -- We typecheck everything up front so that we can use `ExprT`, guaranteeing existence of metadata.
+  , selection :: Maybe DefSelectionT
   }
   deriving stock (Eq, Show, Read, Generic)
   deriving (ToJSON, FromJSON) via PrimerJSON Model
 
 data Action
   = NoOp Text -- For situations where Miso requires an action, but we don't actually want to do anything.
+  | SelectDef GVarName
   | SelectNode NodeSelectionT
   deriving stock (Eq, Show)
 
 updateModel :: Action -> Model -> Effect Action Model
 updateModel =
   fromTransition . \case
     NoOp _ -> pure ()
-    SelectNode sel -> #selection ?= sel
+    SelectDef d -> #selection ?= DefSelection d Nothing
+    SelectNode sel -> #selection % _Just % #node ?= sel
 
 viewModel :: Model -> View Action
 viewModel Model{..} =
   div_
     []
     [ div_
-        [ style_
-            [ ("display", "grid")
-            , ("grid-template-columns", "1fr 1fr 1fr")
-            , ("justify-items", "center")
+        []
+        $ Map.keys module_.defs <&> \(qualifyName module_.name -> def) ->
+          button_
+            [onClick $ SelectDef def]
+            [text $ globalNamePretty def]
+    , case selection of
+        Nothing -> "no selection"
+        Just defSel ->
+          div_
+            []
+            [ div_
+                [ style_
+                    [ ("display", "grid")
+                    , ("grid-template-columns", "1fr 1fr 1fr")
+                    , ("justify-items", "center")
+                    ]
+                ]
+                [ SelectNode . NodeSelection SigNode <$> viewTree (viewTreeType def.sig)
+                , SelectNode . NodeSelection BodyNode <$> viewTree (viewTreeExpr def.expr)
+                , NoOp "clicked non-interactive node" <$ case defSel.node of
+                    Nothing -> viewTree $ viewTreeType $ forgetTypeMetadata def.sig
+                    Just s -> case nodeSelectionType s of
+                      Left t -> viewTree $ viewTreeType t
+                      Right (Left t) -> viewTree $ viewTreeKind t
+                      -- TODO this isn't really correct - kinds in Primer don't have kinds
+                      Right (Right ()) -> viewTree $ viewTreeKind $ KType ()
+                ]
             ]
-        ]
-        [ SelectNode . NodeSelection SigNode <$> viewTree (viewTreeType def.sig)
-        , SelectNode . NodeSelection BodyNode <$> viewTree (viewTreeExpr def.expr)
-        , case selection of
-            Nothing -> "no selection"
-            Just s ->
-              NoOp "clicked non-interactive node" <$ case nodeSelectionType s of
-                Left t -> viewTree $ viewTreeType t
-                Right (Left t) -> viewTree $ viewTreeKind t
-                -- TODO this isn't really correct - kinds in Primer don't have kinds
-                Right (Right ()) -> viewTree $ viewTreeKind $ KType ()
-        ]
+          where
+            -- TODO better error handling
+            def = fromMaybe (error "selected def not found") $ module_.defs !? baseName defSel.def
     ]
 
 data NodeViewData

primer-miso/src/Primer/Miso/Util.hs

@@ -22,18 +22,21 @@ module Primer.Miso.Util (
   TypeMetaT,
   KindMetaT,
   ASTDefT (..),
+  ModuleT (..),
   kindsInType,
   bindingsInExpr,
   typeBindingsInExpr,
   bindingsInType,
   nodeSelectionType,
+  DefSelectionT,
 ) where
 
 import Foreword hiding (zero)
 
 import Control.Monad.Extra (eitherM)
 import Control.Monad.Fresh (MonadFresh (..))
 import Data.Aeson (FromJSON, ToJSON)
+import Data.Map qualified as Map
 import Linear (Additive, R1 (_x), R2 (_y), V2, zero)
 import Linear.Affine (Point (..), unP)
 import Miso (
@@ -55,23 +58,25 @@ import Optics (
   (^.),
  )
 import Optics.State.Operators ((<<%=))
-import Primer.App (NodeSelection (meta), Prog, progCxt)
+import Primer.App (DefSelection, NodeSelection (meta), Prog, progCxt)
 import Primer.Core (
   Expr' (LAM, Lam, Let, LetType, Letrec),
   ID,
   Kind' (KType),
   LVarName,
   Meta,
+  ModuleName,
   TyVarName,
   Type' (TEmptyHole, TForall, THole, TLet),
   TypeCache (..),
   TypeCacheBoth (TCBoth, tcChkedAt, tcSynthed),
   _type,
  )
 import Primer.Core.Utils (forgetTypeMetadata)
-import Primer.Def (ASTDef (..), astDefExpr)
+import Primer.Def (ASTDef (..), astDefExpr, defAST)
 import Primer.JSON (CustomJSON (..), PrimerJSON)
-import Primer.Name (NameCounter)
+import Primer.Module (Module (moduleName), moduleDefs)
+import Primer.Name (Name, NameCounter)
 import Primer.Typecheck (ExprT, TypeError, check, checkKind)
 
 {- Miso -}
@@ -131,13 +136,14 @@ instance (HasField "y" (f a) a) => HasField "y" (Point f a) a where
 
 -- `tcWholeProg` throws away information by not returning a prog containing `ExprT`s
 -- we use `check` since, for whatever reason, `synth` deletes the case branches in `map`
-tcBasicProg :: Prog -> ASTDef -> Either TypeError ASTDefT
-tcBasicProg p ASTDef{..} =
+tcBasicProg :: Prog -> Module -> Either TypeError ModuleT
+tcBasicProg p m =
   runTC
     . flip (runReaderT @_ @(M TypeError)) (progCxt p)
-    $ ASTDefT
-      <$> check (forgetTypeMetadata astDefType) astDefExpr
-      <*> checkKind (KType ()) astDefType
+    $ ModuleT (moduleName m) <$> for (Map.mapMaybe defAST $ moduleDefs m) \ASTDef{..} ->
+      ASTDefT
+        <$> check (forgetTypeMetadata astDefType) astDefExpr
+        <*> checkKind (KType ()) astDefType
 
 -- TODO this is all basically copied from unexposed parts of Primer library - find a way to expose
 newtype M e a = M {unM :: StateT (ID, NameCounter) (Except e) a}
@@ -154,13 +160,20 @@ runTC = runExcept . flip evalStateT (0, toEnum 0) . (.unM)
 -- type SelectionT = Selection' (Either ExprMetaT (Either TypeMetaT KindMetaT))
 type TypeT = Type' TypeMetaT KindMetaT -- TODO actually exists in Primer lib but is hidden
 type TermMeta' a b c = Either a (Either b c) -- TODO make this a proper sum type
+type DefSelectionT = DefSelection (TermMeta' ExprMetaT TypeMetaT KindMetaT)
 type NodeSelectionT = NodeSelection (TermMeta' ExprMetaT TypeMetaT KindMetaT)
 type ExprMetaT = Meta TypeCache
 type TypeMetaT = Meta (Kind' ())
 type KindMetaT = Meta ()
 data ASTDefT = ASTDefT {expr :: ExprT, sig :: TypeT} -- TODO parameterise `ASTDef` etc.?
   deriving stock (Eq, Show, Read, Generic)
   deriving (ToJSON, FromJSON) via PrimerJSON ASTDefT
+data ModuleT = ModuleT -- TODO include type defs and primitives
+  { name :: ModuleName
+  , defs :: Map Name ASTDefT
+  }
+  deriving stock (Eq, Show, Read, Generic)
+  deriving (FromJSON, ToJSON) via PrimerJSON ModuleT
 
 -- analogous to `typesInExpr`
 kindsInType :: AffineTraversal' (Type' a b) (Kind' b)

primer/src/Primer/Core/Meta.hs

@@ -108,7 +108,7 @@ data GlobalName (k :: GlobalNameKind) = GlobalName
   }
   deriving stock (Eq, Ord, Generic, Data, Show, Read)
   deriving (FromJSON, ToJSON) via PrimerJSON (GlobalName k)
-  deriving anyclass (NFData)
+  deriving anyclass (NFData, FromJSONKey, ToJSONKey)
 
 -- | 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.