Skip to content

Commit

Permalink
feat(primer-miso): Select from multiple definitions
Browse files Browse the repository at this point in the history
Signed-off-by: George Thomas <[email protected]>
  • Loading branch information
georgefst committed Jan 2, 2025
1 parent 53c8577 commit d6b791a
Show file tree
Hide file tree
Showing 3 changed files with 76 additions and 39 deletions.
84 changes: 54 additions & 30 deletions primer-miso/src/Primer/Miso.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoFieldSelectors #-}

module Primer.Miso (start) where
Expand All @@ -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
Expand All @@ -36,6 +38,7 @@ import Miso (
JSM,
LogLevel (Off),
View,
button_,
defaultEvents,
div_,
fromTransition,
Expand All @@ -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),
Expand All @@ -72,6 +76,7 @@ import Primer.Core (
PrimCon,
Var
),
GVarName,
GlobalName (baseName, qualifiedModule),
Kind' (..),
LocalName (unLocalName),
Expand All @@ -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,
Expand All @@ -112,6 +119,8 @@ import Primer.Miso.Layout (
)
import Primer.Miso.Util (
ASTDefT (expr, sig),
DefSelectionT,
ModuleT (..),
NodeSelectionT,
TermMeta',
bindingsInExpr,
Expand All @@ -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 = []
Expand All @@ -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
Expand Down
29 changes: 21 additions & 8 deletions primer-miso/src/Primer/Miso/Util.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 (
Expand All @@ -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 -}
Expand Down Expand Up @@ -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}
Expand All @@ -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)
Expand Down
2 changes: 1 addition & 1 deletion primer/src/Primer/Core/Meta.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down

0 comments on commit d6b791a

Please sign in to comment.