Skip to content

Commit

Permalink
fix: Remove unsafe FromJSON Name instance
Browse files Browse the repository at this point in the history
Because it used `deriving newtype`, this instance constructed names without any validation, similarly to `unsafeMkName`. While we don't currently have any name validation, we expect that we will soon move to a "smart constructor" approach, ripping out most uses of `unsafeMkName`. We don't then want `fromJSON @Name` to remain as a validation-skipping backdoor.

An alternative would be to use our smart constructor (i.e. `safeMkName`) in a manual implementation of `fromJSON`. But given that the instance is unused (other than to define more unused instances for types which contain `Name`), we may as well just remove it.

N.B. This instance has been around since our old prototype frontend, and may have been useful back then.
  • Loading branch information
georgefst committed Jan 17, 2023
1 parent c8df8fd commit a313773
Show file tree
Hide file tree
Showing 25 changed files with 65 additions and 68 deletions.
4 changes: 2 additions & 2 deletions primer/src/Primer/API.hs
Original file line number Diff line number Diff line change
Expand Up @@ -1170,7 +1170,7 @@ data ApplyActionBody = ApplyActionBody
, option :: Available.Option
}
deriving (Generic, Show)
deriving (FromJSON, ToJSON) via PrimerJSON ApplyActionBody
deriving (ToJSON) via PrimerJSON ApplyActionBody

applyActions :: (MonadIO m, MonadThrow m, MonadAPILog l m) => ExprTreeOpts -> SessionId -> [ProgAction] -> PrimerM m Prog
applyActions opts sid actions =
Expand All @@ -1185,7 +1185,7 @@ data Selection = Selection
, node :: Maybe NodeSelection
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON Selection
deriving (ToJSON) via PrimerJSON Selection

viewSelection :: App.Selection -> Selection
viewSelection App.Selection{..} = Selection{def = selectedDef, node = viewNodeSelection <$> selectedNode}
Expand Down
6 changes: 3 additions & 3 deletions primer/src/Primer/Action/Actions.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ module Primer.Action.Actions (

import Foreword

import Data.Aeson (FromJSON (..), ToJSON (..), Value)
import Data.Aeson (ToJSON (..), Value)
import Primer.Core (PrimCon)
import Primer.Core.Meta (ID, TmVarRef, ValConName)
import Primer.JSON (CustomJSON (..), PrimerJSON)
Expand Down Expand Up @@ -102,9 +102,9 @@ data Action
| -- | Rename a case binding
RenameCaseBinding Text
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON Action
deriving (ToJSON) via PrimerJSON Action

-- | Core movements
data Movement = Child1 | Child2 | Parent | Branch ValConName
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON Movement
deriving (ToJSON) via PrimerJSON Movement
4 changes: 2 additions & 2 deletions primer/src/Primer/Action/Errors.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@ module Primer.Action.Errors (ActionError (..)) where

import Foreword

import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson (ToJSON (..))
import Primer.Action.Actions (Action)
import Primer.Action.Available qualified as Available
import Primer.Core (Expr, GVarName, ID, LVarName, ModuleName, Type)
Expand Down Expand Up @@ -63,4 +63,4 @@ data ActionError
| NeedChar Available.Option
| NoNodeSelection
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON ActionError
deriving (ToJSON) via PrimerJSON ActionError
4 changes: 2 additions & 2 deletions primer/src/Primer/Action/ProgAction.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,7 @@ module Primer.Action.ProgAction (ProgAction (..)) where

import Foreword

import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson (ToJSON (..))
import Primer.Action.Actions (Action)
import Primer.Core.Meta (GVarName, ID, ModuleName, TyConName, TyVarName, ValConName)
import Primer.Core.Type (Type')
Expand Down Expand Up @@ -64,4 +64,4 @@ data ProgAction
| -- | Renames an editable module (will return an error if asked to rename an imported module)
RenameModule ModuleName (NonEmpty Text)
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON ProgAction
deriving (ToJSON) via PrimerJSON ProgAction
4 changes: 2 additions & 2 deletions primer/src/Primer/Action/ProgError.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@ module Primer.Action.ProgError (ProgError (..)) where

import Foreword

import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson (ToJSON (..))
import Primer.Action.Errors (ActionError)
import Primer.Core.Meta (GVarName, ModuleName, TyConName, TyVarName, ValConName)
import Primer.Eval.EvalError (EvalError)
Expand Down Expand Up @@ -44,4 +44,4 @@ data ProgError
| -- | Cannot edit an imported module
ModuleReadonly ModuleName
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON ProgError
deriving (ToJSON) via PrimerJSON ProgError
22 changes: 11 additions & 11 deletions primer/src/Primer/App.hs
Original file line number Diff line number Diff line change
Expand Up @@ -230,7 +230,7 @@ data Prog = Prog
, progLog :: Log -- The log of all actions
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON Prog
deriving (ToJSON) via PrimerJSON Prog

-- | The default 'Prog'. It has no imports, no definitions, no current
-- 'Selection', and an empty 'Log'. Smart holes are enabled.
Expand Down Expand Up @@ -379,7 +379,7 @@ allDefs = fmap snd . progAllDefs
-- Items are stored in reverse order so it's quick to add new ones.
newtype Log = Log {unlog :: [[ProgAction]]}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON Log
deriving (ToJSON) via PrimerJSON Log

-- | The default (empty) 'Log'.
defaultLog :: Log
Expand All @@ -393,7 +393,7 @@ data Selection = Selection
, selectedNode :: Maybe NodeSelection
}
deriving (Eq, Show, Generic, Data)
deriving (FromJSON, ToJSON) via PrimerJSON Selection
deriving (ToJSON) via PrimerJSON Selection

-- | A selected node, in the body or type signature of some definition.
-- We have the following invariant: @nodeType = SigNode ==> isRight meta@
Expand All @@ -402,7 +402,7 @@ data NodeSelection = NodeSelection
, meta :: Either ExprMeta TypeMeta
}
deriving (Eq, Show, Generic, Data)
deriving (FromJSON, ToJSON) via PrimerJSON NodeSelection
deriving (ToJSON) via PrimerJSON NodeSelection

instance HasID NodeSelection where
_id =
Expand All @@ -415,37 +415,37 @@ data MutationRequest
= Undo
| Edit [ProgAction]
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON MutationRequest
deriving (ToJSON) via PrimerJSON MutationRequest

data EvalReq = EvalReq
{ evalReqExpr :: Expr
, evalReqRedex :: ID
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON EvalReq
deriving (ToJSON) via PrimerJSON EvalReq

data EvalResp = EvalResp
{ evalRespExpr :: Expr
, evalRespRedexes :: [ID]
, evalRespDetail :: EvalDetail
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON EvalResp
deriving (ToJSON) via PrimerJSON EvalResp

data EvalFullReq = EvalFullReq
{ evalFullReqExpr :: Expr
, evalFullCxtDir :: Dir -- is this expression in a syn/chk context, so we can tell if is an embedding.
, evalFullMaxSteps :: TerminationBound
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON EvalFullReq
deriving (ToJSON) via PrimerJSON EvalFullReq

-- If we time out, we still return however far we got
data EvalFullResp
= EvalFullRespTimedOut Expr
| EvalFullRespNormal Expr
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON EvalFullResp
deriving (ToJSON) via PrimerJSON EvalFullResp

-- * Request handlers

Expand Down Expand Up @@ -1049,7 +1049,7 @@ data App = App
, initialState :: AppState
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON App
deriving (ToJSON) via PrimerJSON App

-- Internal app state. Note that this type is not exported, as we want
-- to guarantee that the counters are kept in sync with the 'Prog',
Expand All @@ -1061,7 +1061,7 @@ data AppState = AppState
, prog :: Prog
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON AppState
deriving (ToJSON) via PrimerJSON AppState

-- | Construct an 'App' from an 'ID' and a 'Prog'.
--
Expand Down
10 changes: 5 additions & 5 deletions primer/src/Primer/Core.hs
Original file line number Diff line number Diff line change
Expand Up @@ -95,7 +95,7 @@ data TypeCache
| TCChkedAt (Type' ())
| TCEmb TypeCacheBoth
deriving (Eq, Show, Generic, Data)
deriving (FromJSON, ToJSON) via PrimerJSON TypeCache
deriving (ToJSON) via PrimerJSON TypeCache
deriving anyclass (NFData)

-- We were checking at the first, but term was synthesisable and synth'd the
Expand All @@ -104,7 +104,7 @@ data TypeCache
-- though, to make it clear what each one is!
data TypeCacheBoth = TCBoth {tcChkedAt :: Type' (), tcSynthed :: Type' ()}
deriving (Eq, Show, Generic, Data)
deriving (FromJSON, ToJSON) via PrimerJSON TypeCacheBoth
deriving (ToJSON) via PrimerJSON TypeCacheBoth
deriving anyclass (NFData)

-- TODO `_chkedAt` and `_synthed` should be `AffineTraversal`s,
Expand Down Expand Up @@ -182,7 +182,7 @@ data Expr' a b
| Case a (Expr' a b) [CaseBranch' a b] -- See Note [Case]
| PrimCon a PrimCon
deriving (Eq, Show, Data, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON (Expr' a b)
deriving (ToJSON) via PrimerJSON (Expr' a b)
deriving anyclass (NFData)

-- Note [Synthesisable constructors]
Expand Down Expand Up @@ -257,7 +257,7 @@ data CaseBranch' a b
(Expr' a b)
-- ^ right hand side
deriving (Eq, Show, Data, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON (CaseBranch' a b)
deriving (ToJSON) via PrimerJSON (CaseBranch' a b)
deriving anyclass (NFData)

-- | Variable bindings
Expand All @@ -267,7 +267,7 @@ type Bind = Bind' ExprMeta

data Bind' a = Bind a LVarName
deriving (Eq, Show, Data, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON (Bind' a)
deriving (ToJSON) via PrimerJSON (Bind' a)
deriving anyclass (NFData)

bindName :: Bind' a -> LVarName
Expand Down
8 changes: 4 additions & 4 deletions primer/src/Primer/Core/Meta.hs
Original file line number Diff line number Diff line change
Expand Up @@ -77,7 +77,7 @@ trivialMeta id = Meta id Nothing Nothing

newtype ModuleName = ModuleName {unModuleName :: NonEmpty Name}
deriving (Eq, Ord, Show, Data, Generic)
deriving (FromJSON, ToJSON) via NonEmpty Name
deriving (ToJSON) via NonEmpty Name
deriving anyclass (NFData)

-- | Helper function for simple (non-hierarchical) module names.
Expand All @@ -103,7 +103,7 @@ data GlobalName (k :: GlobalNameKind) = GlobalName
, baseName :: Name
}
deriving (Eq, Ord, Generic, Data, Show)
deriving (FromJSON, ToJSON) via PrimerJSON (GlobalName k)
deriving (ToJSON) via PrimerJSON (GlobalName k)
deriving anyclass (NFData)

-- | Construct a name from a Text. This is called unsafe because there are no
Expand All @@ -129,7 +129,7 @@ data LocalNameKind
newtype LocalName (k :: LocalNameKind) = LocalName {unLocalName :: Name}
deriving (Eq, Ord, Show, Data, Generic)
deriving (IsString) via Name
deriving (FromJSON, ToJSON) via Name
deriving (ToJSON) via Name
deriving anyclass (NFData)

unsafeMkLocalName :: Text -> LocalName k
Expand All @@ -143,7 +143,7 @@ data TmVarRef
= GlobalVarRef GVarName
| LocalVarRef LVarName
deriving (Eq, Show, Data, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON TmVarRef
deriving (ToJSON) via PrimerJSON TmVarRef
deriving anyclass (NFData)

-- | A class for types which have an ID.
Expand Down
2 changes: 1 addition & 1 deletion primer/src/Primer/Core/Type.hs
Original file line number Diff line number Diff line change
Expand Up @@ -59,7 +59,7 @@ data Type' a
(Type' a)
-- ^ body of the let; binding scopes over this
deriving (Eq, Show, Data, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON (Type' a)
deriving (ToJSON) via PrimerJSON (Type' a)
deriving anyclass (NFData)

-- | A traversal over the metadata of a type
Expand Down
5 changes: 2 additions & 3 deletions primer/src/Primer/Def.hs
Original file line number Diff line number Diff line change
Expand Up @@ -21,7 +21,6 @@ import Primer.Core (
import Primer.Core.Utils (forgetTypeMetadata)
import Primer.JSON (
CustomJSON (CustomJSON),
FromJSON,
PrimerJSON,
ToJSON,
)
Expand All @@ -31,7 +30,7 @@ data Def
= DefPrim PrimDef
| DefAST ASTDef
deriving (Eq, Show, Data, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON Def
deriving (ToJSON) via PrimerJSON Def
deriving anyclass (NFData)

defType :: Def -> Type' ()
Expand All @@ -48,7 +47,7 @@ data ASTDef = ASTDef
, astDefType :: Type
}
deriving (Eq, Show, Data, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON ASTDef
deriving (ToJSON) via PrimerJSON ASTDef
deriving anyclass (NFData)

defAST :: Def -> Maybe ASTDef
Expand Down
4 changes: 2 additions & 2 deletions primer/src/Primer/Eval/Ann.hs
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ import Primer.Core (
Expr,
ID,
)
import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON)
import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON)

data RemoveAnnDetail = RemoveAnnDetail
{ before :: Expr
Expand All @@ -19,4 +19,4 @@ data RemoveAnnDetail = RemoveAnnDetail
-- ^ the ID of the type annotation
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON RemoveAnnDetail
deriving (ToJSON) via PrimerJSON RemoveAnnDetail
4 changes: 2 additions & 2 deletions primer/src/Primer/Eval/Beta.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@ import Primer.Core (
ID,
LocalName,
)
import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON)
import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON)

-- | Detailed information about a beta reduction (of a λ or Λ).
-- If λ:
Expand All @@ -33,4 +33,4 @@ data BetaReductionDetail k domain codomain = BetaReductionDetail
, types :: (domain, codomain)
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON (BetaReductionDetail k domain codomain)
deriving (ToJSON) via PrimerJSON (BetaReductionDetail k domain codomain)
4 changes: 2 additions & 2 deletions primer/src/Primer/Eval/Bind.hs
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,7 @@ import Foreword
import Primer.Core (
ID,
)
import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON)
import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON)
import Primer.Name (Name)

-- | Detailed information about a renaming of a binding.
Expand Down Expand Up @@ -39,4 +39,4 @@ data BindRenameDetail t = BindRenameDetail
-- ^ the right hand side of the binders
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON (BindRenameDetail t)
deriving (ToJSON) via PrimerJSON (BindRenameDetail t)
4 changes: 2 additions & 2 deletions primer/src/Primer/Eval/Case.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@ import Primer.Core (
ID,
ValConName,
)
import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON)
import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON)

data CaseReductionDetail = CaseReductionDetail
{ before :: Expr
Expand All @@ -32,4 +32,4 @@ data CaseReductionDetail = CaseReductionDetail
-- ^ the let expressions binding each argument in the result
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON CaseReductionDetail
deriving (ToJSON) via PrimerJSON CaseReductionDetail
4 changes: 2 additions & 2 deletions primer/src/Primer/Eval/Detail.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,7 @@ import Primer.Eval.Case as Case
import Primer.Eval.Inline as Inline
import Primer.Eval.Let as Let
import Primer.Eval.Prim as Prim
import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON)
import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON)

-- | Detailed information about a reduction step
data EvalDetail
Expand Down Expand Up @@ -52,4 +52,4 @@ data EvalDetail
| -- | Apply a primitive function
ApplyPrimFun ApplyPrimFunDetail
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON EvalDetail
deriving (ToJSON) via PrimerJSON EvalDetail
6 changes: 3 additions & 3 deletions primer/src/Primer/Eval/Inline.hs
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@ import Primer.Core (
LocalName,
)
import Primer.Def (ASTDef)
import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON)
import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON)

data LocalVarInlineDetail k = LocalVarInlineDetail
{ letID :: ID
Expand All @@ -31,7 +31,7 @@ data LocalVarInlineDetail k = LocalVarInlineDetail
-- Otherwise it is a term variable.
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON (LocalVarInlineDetail k)
deriving (ToJSON) via PrimerJSON (LocalVarInlineDetail k)

data GlobalVarInlineDetail = GlobalVarInlineDetail
{ def :: ASTDef
Expand All @@ -42,4 +42,4 @@ data GlobalVarInlineDetail = GlobalVarInlineDetail
-- ^ The result of the reduction
}
deriving (Eq, Show, Generic)
deriving (FromJSON, ToJSON) via PrimerJSON GlobalVarInlineDetail
deriving (ToJSON) via PrimerJSON GlobalVarInlineDetail
Loading

0 comments on commit a313773

Please sign in to comment.