From d24cca32183b1796c390245b26549c9595569a06 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 17 Jan 2023 12:18:46 +0000 Subject: [PATCH 1/2] fix: Remove unsafe `FromJSON Name` instance 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. --- primer-service/src/Primer/Servant/OpenAPI.hs | 4 ++-- primer/src/Primer/API.hs | 4 ++-- primer/src/Primer/Action/Actions.hs | 6 +++--- primer/src/Primer/Action/Errors.hs | 4 ++-- primer/src/Primer/Action/ProgAction.hs | 4 ++-- primer/src/Primer/Action/ProgError.hs | 4 ++-- primer/src/Primer/App.hs | 22 ++++++++++---------- primer/src/Primer/Core.hs | 10 ++++----- primer/src/Primer/Core/Meta.hs | 8 +++---- primer/src/Primer/Core/Type.hs | 2 +- primer/src/Primer/Def.hs | 5 ++--- primer/src/Primer/Eval/Ann.hs | 4 ++-- primer/src/Primer/Eval/Beta.hs | 4 ++-- primer/src/Primer/Eval/Bind.hs | 4 ++-- primer/src/Primer/Eval/Case.hs | 4 ++-- primer/src/Primer/Eval/Detail.hs | 4 ++-- primer/src/Primer/Eval/Inline.hs | 6 +++--- primer/src/Primer/Eval/Let.hs | 4 ++-- primer/src/Primer/Eval/Prim.hs | 4 ++-- primer/src/Primer/Module.hs | 3 +-- primer/src/Primer/Name.hs | 2 +- primer/src/Primer/Primitives.hs | 4 ++-- primer/src/Primer/TypeDef.hs | 9 ++++---- primer/src/Primer/Typecheck/KindError.hs | 4 ++-- primer/src/Primer/Typecheck/TypeError.hs | 4 ++-- primer/src/Primer/Zipper.hs | 4 ++-- 26 files changed, 67 insertions(+), 70 deletions(-) diff --git a/primer-service/src/Primer/Servant/OpenAPI.hs b/primer-service/src/Primer/Servant/OpenAPI.hs index da22ea193..f0268c788 100644 --- a/primer-service/src/Primer/Servant/OpenAPI.hs +++ b/primer-service/src/Primer/Servant/OpenAPI.hs @@ -24,7 +24,7 @@ import Primer.Database ( SessionId, ) import Primer.Finite (Finite) -import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON) +import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON) import Primer.OpenAPI () import Primer.Servant.Types ( CopySession, @@ -143,7 +143,7 @@ data CreateTypeDefBody = CreateTypeDefBody , ctors :: [Text] } deriving stock (Generic, Show) - deriving (FromJSON, ToJSON) via PrimerJSON CreateTypeDefBody + deriving (ToJSON) via PrimerJSON CreateTypeDefBody deriving (ToSchema) via PrimerJSON CreateTypeDefBody data ActionAPI mode = ActionAPI diff --git a/primer/src/Primer/API.hs b/primer/src/Primer/API.hs index 7fe657888..319ec04c8 100644 --- a/primer/src/Primer/API.hs +++ b/primer/src/Primer/API.hs @@ -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 = @@ -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} diff --git a/primer/src/Primer/Action/Actions.hs b/primer/src/Primer/Action/Actions.hs index ff0001221..caac52d48 100644 --- a/primer/src/Primer/Action/Actions.hs +++ b/primer/src/Primer/Action/Actions.hs @@ -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) @@ -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 diff --git a/primer/src/Primer/Action/Errors.hs b/primer/src/Primer/Action/Errors.hs index 1f06529bf..b081b98e4 100644 --- a/primer/src/Primer/Action/Errors.hs +++ b/primer/src/Primer/Action/Errors.hs @@ -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) @@ -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 diff --git a/primer/src/Primer/Action/ProgAction.hs b/primer/src/Primer/Action/ProgAction.hs index 0594ad0b2..1829feed9 100644 --- a/primer/src/Primer/Action/ProgAction.hs +++ b/primer/src/Primer/Action/ProgAction.hs @@ -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') @@ -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 diff --git a/primer/src/Primer/Action/ProgError.hs b/primer/src/Primer/Action/ProgError.hs index 803317cc8..ca2c7a2ad 100644 --- a/primer/src/Primer/Action/ProgError.hs +++ b/primer/src/Primer/Action/ProgError.hs @@ -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) @@ -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 diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index afff41be3..66617cc01 100644 --- a/primer/src/Primer/App.hs +++ b/primer/src/Primer/App.hs @@ -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. @@ -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 @@ -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@ @@ -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 = @@ -415,14 +415,14 @@ 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 @@ -430,7 +430,7 @@ data EvalResp = EvalResp , evalRespDetail :: EvalDetail } deriving (Eq, Show, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON EvalResp + deriving (ToJSON) via PrimerJSON EvalResp data EvalFullReq = EvalFullReq { evalFullReqExpr :: Expr @@ -438,14 +438,14 @@ data EvalFullReq = EvalFullReq , 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 @@ -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', @@ -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'. -- diff --git a/primer/src/Primer/Core.hs b/primer/src/Primer/Core.hs index b52cb8892..f6d3c5d66 100644 --- a/primer/src/Primer/Core.hs +++ b/primer/src/Primer/Core.hs @@ -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 @@ -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, @@ -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] @@ -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 @@ -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 diff --git a/primer/src/Primer/Core/Meta.hs b/primer/src/Primer/Core/Meta.hs index 88535bfd3..3ec81f929 100644 --- a/primer/src/Primer/Core/Meta.hs +++ b/primer/src/Primer/Core/Meta.hs @@ -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. @@ -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 @@ -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 @@ -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. diff --git a/primer/src/Primer/Core/Type.hs b/primer/src/Primer/Core/Type.hs index 5cd5ff868..7bd6b99d3 100644 --- a/primer/src/Primer/Core/Type.hs +++ b/primer/src/Primer/Core/Type.hs @@ -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 diff --git a/primer/src/Primer/Def.hs b/primer/src/Primer/Def.hs index c08e5582a..f2a6a8d97 100644 --- a/primer/src/Primer/Def.hs +++ b/primer/src/Primer/Def.hs @@ -21,7 +21,6 @@ import Primer.Core ( import Primer.Core.Utils (forgetTypeMetadata) import Primer.JSON ( CustomJSON (CustomJSON), - FromJSON, PrimerJSON, ToJSON, ) @@ -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' () @@ -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 diff --git a/primer/src/Primer/Eval/Ann.hs b/primer/src/Primer/Eval/Ann.hs index 50ce95e78..f8c452f77 100644 --- a/primer/src/Primer/Eval/Ann.hs +++ b/primer/src/Primer/Eval/Ann.hs @@ -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 @@ -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 diff --git a/primer/src/Primer/Eval/Beta.hs b/primer/src/Primer/Eval/Beta.hs index e2bffd29c..2758251fe 100644 --- a/primer/src/Primer/Eval/Beta.hs +++ b/primer/src/Primer/Eval/Beta.hs @@ -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 λ: @@ -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) diff --git a/primer/src/Primer/Eval/Bind.hs b/primer/src/Primer/Eval/Bind.hs index be0de6161..3212f30e8 100644 --- a/primer/src/Primer/Eval/Bind.hs +++ b/primer/src/Primer/Eval/Bind.hs @@ -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. @@ -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) diff --git a/primer/src/Primer/Eval/Case.hs b/primer/src/Primer/Eval/Case.hs index 44146ca02..2dd6683c0 100644 --- a/primer/src/Primer/Eval/Case.hs +++ b/primer/src/Primer/Eval/Case.hs @@ -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 @@ -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 diff --git a/primer/src/Primer/Eval/Detail.hs b/primer/src/Primer/Eval/Detail.hs index 3651436d0..e105ee263 100644 --- a/primer/src/Primer/Eval/Detail.hs +++ b/primer/src/Primer/Eval/Detail.hs @@ -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 @@ -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 diff --git a/primer/src/Primer/Eval/Inline.hs b/primer/src/Primer/Eval/Inline.hs index c7fa92494..4d4c46c16 100644 --- a/primer/src/Primer/Eval/Inline.hs +++ b/primer/src/Primer/Eval/Inline.hs @@ -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 @@ -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 @@ -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 diff --git a/primer/src/Primer/Eval/Let.hs b/primer/src/Primer/Eval/Let.hs index 8a807a856..5b6b6dd2c 100644 --- a/primer/src/Primer/Eval/Let.hs +++ b/primer/src/Primer/Eval/Let.hs @@ -19,7 +19,7 @@ import Primer.Core ( getID, ) import Primer.Core.Utils (_freeVars, _freeVarsTy) -import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON) +import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON) import Primer.Name (Name) -- | Detailed information about a removal of a let binding. @@ -40,7 +40,7 @@ data LetRemovalDetail t = LetRemovalDetail -- ^ the right hand side of the let } deriving (Eq, Show, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON (LetRemovalDetail t) + deriving (ToJSON) via PrimerJSON (LetRemovalDetail t) findFreeOccurrencesExpr :: LocalName k -> Expr -> [ID] findFreeOccurrencesExpr x e = e ^.. _freeVars % to idName % filtered ((== unLocalName x) . snd) % _1 diff --git a/primer/src/Primer/Eval/Prim.hs b/primer/src/Primer/Eval/Prim.hs index 2e6858c08..682cdf05b 100644 --- a/primer/src/Primer/Eval/Prim.hs +++ b/primer/src/Primer/Eval/Prim.hs @@ -16,7 +16,7 @@ import Primer.Core ( ) import Primer.Core.Transform (unfoldApp) import Primer.Core.Utils (concreteTy, forgetMetadata) -import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON) +import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON) import Primer.Primitives (PrimDef, primFunDef) data ApplyPrimFunDetail = ApplyPrimFunDetail @@ -30,7 +30,7 @@ data ApplyPrimFunDetail = ApplyPrimFunDetail -- ^ the IDs of the arguments to the application } deriving (Eq, Show, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON ApplyPrimFunDetail + deriving (ToJSON) via PrimerJSON ApplyPrimFunDetail -- | If this node is a reducible application of a primitive, return the name of the primitive, the arguments, and -- (a computation for building) the result. diff --git a/primer/src/Primer/Module.hs b/primer/src/Primer/Module.hs index 34372a3d1..f73ede51f 100644 --- a/primer/src/Primer/Module.hs +++ b/primer/src/Primer/Module.hs @@ -51,7 +51,6 @@ import Primer.Def ( import Primer.Def.Utils (nextID) import Primer.JSON ( CustomJSON (CustomJSON), - FromJSON, PrimerJSON, ToJSON, ) @@ -65,7 +64,7 @@ data Module = Module , moduleDefs :: Map Name Def -- The current program: a set of definitions indexed by Name } deriving (Eq, Show, Data, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON Module + deriving (ToJSON) via PrimerJSON Module qualifyTyConName :: Module -> Name -> TyConName qualifyTyConName m = qualifyName (moduleName m) diff --git a/primer/src/Primer/Name.hs b/primer/src/Primer/Name.hs index e9bbb3ca6..d9d5ff1f9 100644 --- a/primer/src/Primer/Name.hs +++ b/primer/src/Primer/Name.hs @@ -25,7 +25,7 @@ import Primer.JSON newtype Name = Name {unName :: Text} deriving (Eq, Ord, Generic, Data) deriving newtype (Show, IsString) - deriving newtype (FromJSON, ToJSON, FromJSONKey, ToJSONKey) + deriving newtype (ToJSON, ToJSONKey) deriving anyclass (NFData) -- | Construct a name from a Text. This is called unsafe because there are no diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index e983fbe4e..4bd71b912 100644 --- a/primer/src/Primer/Primitives.hs +++ b/primer/src/Primer/Primitives.hs @@ -19,7 +19,7 @@ module Primer.Primitives ( import Foreword import Control.Monad.Fresh (MonadFresh) -import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Aeson (ToJSON (..)) import Data.Data (Data) import Data.Map qualified as M import Numeric.Natural (Natural) @@ -66,7 +66,7 @@ data PrimFunError [Expr' () ()] -- ^ Arguments deriving (Eq, Show, Data, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON PrimFunError + deriving (ToJSON) via PrimerJSON PrimFunError primitiveModuleName :: ModuleName primitiveModuleName = mkSimpleModuleName "Primitives" diff --git a/primer/src/Primer/TypeDef.hs b/primer/src/Primer/TypeDef.hs index ddd833970..935d43069 100644 --- a/primer/src/Primer/TypeDef.hs +++ b/primer/src/Primer/TypeDef.hs @@ -25,7 +25,6 @@ import Primer.Core.Type ( ) import Primer.JSON ( CustomJSON (CustomJSON), - FromJSON, PrimerJSON, ToJSON, ) @@ -35,7 +34,7 @@ data TypeDef = TypeDefPrim PrimTypeDef | TypeDefAST ASTTypeDef deriving (Eq, Show, Data, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON TypeDef + deriving (ToJSON) via PrimerJSON TypeDef -- | A mapping of global names to 'TypeDef's. type TypeDefMap = Map TyConName TypeDef @@ -46,7 +45,7 @@ data PrimTypeDef = PrimTypeDef , primTypeDefNameHints :: [Name] } deriving (Eq, Show, Data, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON PrimTypeDef + deriving (ToJSON) via PrimerJSON PrimTypeDef -- | Definition of an algebraic data type -- @@ -59,14 +58,14 @@ data ASTTypeDef = ASTTypeDef , astTypeDefNameHints :: [Name] } deriving (Eq, Show, Data, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON ASTTypeDef + deriving (ToJSON) via PrimerJSON ASTTypeDef data ValCon = ValCon { valConName :: ValConName , valConArgs :: [Type' ()] } deriving (Eq, Show, Data, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON ValCon + deriving (ToJSON) via PrimerJSON ValCon valConType :: TyConName -> ASTTypeDef -> ValCon -> Type' () valConType tc td vc = diff --git a/primer/src/Primer/Typecheck/KindError.hs b/primer/src/Primer/Typecheck/KindError.hs index 6f1dba2de..10aef74de 100644 --- a/primer/src/Primer/Typecheck/KindError.hs +++ b/primer/src/Primer/Typecheck/KindError.hs @@ -4,7 +4,7 @@ import Foreword import Primer.Core.Meta (TyConName, TyVarName) import Primer.Core.Type (Kind) -import Primer.JSON (CustomJSON (..), FromJSON, PrimerJSON, ToJSON) +import Primer.JSON (CustomJSON (..), PrimerJSON, ToJSON) import Primer.Name (Name) data KindError @@ -17,4 +17,4 @@ data KindError -- they should only transiently appear in evaluation, as explicit substitutions. TLetUnsupported deriving (Eq, Show, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON KindError + deriving (ToJSON) via PrimerJSON KindError diff --git a/primer/src/Primer/Typecheck/TypeError.hs b/primer/src/Primer/Typecheck/TypeError.hs index 33c80be40..41d06763e 100644 --- a/primer/src/Primer/Typecheck/TypeError.hs +++ b/primer/src/Primer/Typecheck/TypeError.hs @@ -5,7 +5,7 @@ import Foreword import Primer.Core (Expr) import Primer.Core.Meta (TmVarRef, TyConName, ValConName) import Primer.Core.Type (Type') -import Primer.JSON (CustomJSON (..), FromJSON, PrimerJSON, ToJSON) +import Primer.JSON (CustomJSON (..), PrimerJSON, ToJSON) import Primer.Name (Name) import Primer.Typecheck.KindError (KindError) @@ -29,4 +29,4 @@ data TypeError | CaseBranchWrongNumberPatterns | KindError KindError deriving (Eq, Show, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON TypeError + deriving (ToJSON) via PrimerJSON TypeError diff --git a/primer/src/Primer/Zipper.hs b/primer/src/Primer/Zipper.hs index 064c1d70b..6b481a9f5 100644 --- a/primer/src/Primer/Zipper.hs +++ b/primer/src/Primer/Zipper.hs @@ -111,7 +111,7 @@ import Primer.Core ( getID, typesInExpr, ) -import Primer.JSON (CustomJSON (CustomJSON), FromJSON, PrimerJSON, ToJSON) +import Primer.JSON (CustomJSON (CustomJSON), PrimerJSON, ToJSON) import Primer.Name (Name) import Primer.Zipper.Type ( FoldAbove, @@ -457,4 +457,4 @@ data SomeNode | -- | If/when we model all bindings with 'Bind'', we will want to generalise this. CaseBindNode Bind deriving (Eq, Show, Generic) - deriving (FromJSON, ToJSON) via PrimerJSON SomeNode + deriving (ToJSON) via PrimerJSON SomeNode From c93e3166559bc497f6dbc14a16dd464af5004806 Mon Sep 17 00:00:00 2001 From: George Thomas Date: Tue, 17 Jan 2023 12:26:55 +0000 Subject: [PATCH 2/2] undo - total hack! --- primer-rel8/src/Primer/Database/Rel8/Orphans.hs | 5 ++++- primer-service/src/Primer/Client.hs | 5 ++++- primer-service/src/Primer/Server.hs | 5 ++++- primer/test/Tests/Serialization.hs | 16 ++++------------ 4 files changed, 16 insertions(+), 15 deletions(-) diff --git a/primer-rel8/src/Primer/Database/Rel8/Orphans.hs b/primer-rel8/src/Primer/Database/Rel8/Orphans.hs index b57bbf8bc..66ec32495 100644 --- a/primer-rel8/src/Primer/Database/Rel8/Orphans.hs +++ b/primer-rel8/src/Primer/Database/Rel8/Orphans.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-missing-methods #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- This module exists so that we don't need a dependency on "Rel8" in @@ -11,4 +13,5 @@ import Rel8 ( JSONBEncoded (..), ) -deriving via JSONBEncoded App instance DBType App +-- deriving via JSONBEncoded App instance DBType App +instance DBType App diff --git a/primer-service/src/Primer/Client.hs b/primer-service/src/Primer/Client.hs index b36feb48c..b6b7b0c91 100644 --- a/primer-service/src/Primer/Client.hs +++ b/primer-service/src/Primer/Client.hs @@ -1,3 +1,6 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + -- | A Primer Servant API client. -- -- This module exposes the full Primer API over HTTP. @@ -74,7 +77,7 @@ defaultAPIPath = "/api" -- | A client for the full Primer API. apiClient :: API.RootAPI (AsClientT ClientM) -apiClient = genericClient +apiClient = undefined -- | As 'Primer.API.copySession'. copySession :: SessionId -> ClientM SessionId diff --git a/primer-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs index 3bce98bb4..5288c8146 100644 --- a/primer-service/src/Primer/Server.hs +++ b/primer-service/src/Primer/Server.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} -- | An HTTP service for the Primer API. module Primer.Server ( @@ -259,7 +262,7 @@ serve ss q v port logger = do noCache $ cors (const $ Just apiCors) $ metrics $ - genericServeT nt server + undefined nt (server @l) where -- By default Warp will try to bind on either IPv4 or IPv6, whichever is -- available. diff --git a/primer/test/Tests/Serialization.hs b/primer/test/Tests/Serialization.hs index 22bae6ca3..0afdbad64 100644 --- a/primer/test/Tests/Serialization.hs +++ b/primer/test/Tests/Serialization.hs @@ -68,7 +68,6 @@ import Primer.Typecheck (SmartHoles (SmartHoles)) import System.FilePath (takeBaseName) import Test.Tasty hiding (after) import Test.Tasty.Golden -import Test.Tasty.HUnit -- | Check that encoding the value produces the file. test_encode :: TestTree @@ -82,18 +81,11 @@ test_encode = encodePretty :: ToJSON a => a -> BL.ByteString encodePretty = encodePretty' $ defConfig{confCompare = compare} --- | Check that decoding the file produces the value. -test_decode :: TestTree -test_decode = - testGroup "decode" $ - fixtures <&> \(Fixture x path) -> - testCase (takeBaseName path) $ either assertFailure (x @=?) =<< eitherDecodeFileStrict path - -- | A fixture holds some value which is JSON serializable and path to a -- fixture file which should contain a JSON representation of that value. -data Fixture = forall a. (Eq a, Show a, FromJSON a, ToJSON a) => Fixture a FilePath +data Fixture = forall a. (Eq a, Show a, ToJSON a) => Fixture a FilePath -mkFixture :: (Eq a, Show a, ToJSON a, FromJSON a) => String -> a -> Fixture +mkFixture :: (Eq a, Show a, ToJSON a) => String -> a -> Fixture mkFixture name x = Fixture x ("test/outputs/serialization/" <> name <> ".json") -- | A list of fixtures we will test. @@ -164,7 +156,7 @@ fixtures = , bodyID = id0 , types = (TEmptyHole typeMeta, TEmptyHole typeMeta) } - in [ mkFixture "id" id0 + in [ mkFixture "id" id0 -- TODO this does still have a FromJSON instance , mkFixture "name" (unsafeMkName "x") , mkFixture "movement" Child1 , mkFixture "action" (SetCursor id0) @@ -173,7 +165,7 @@ fixtures = , mkFixture "typecache" (TCSynthed $ TEmptyHole ()) , mkFixture "typecacheboth" (TCBoth (TEmptyHole ()) (TEmptyHole ())) , mkFixture "expr" expr - , mkFixture "kind" KType + , mkFixture "kind" KType -- TODO this does still have a FromJSON instance , mkFixture "log" log , mkFixture "def" def , mkFixture "typeDef" typeDef