Skip to content

Commit 0efcb89

Browse files
SeungheonOhSeungheonOh
authored
Throw compilation error when unsupported extension is enabled (#7252)
* Throw compilation error when unsupported extension(in this case just GADTs) is enabled * Add more unsupported extensions to the check * Fix build * purge gadts * changelog
1 parent c268f35 commit 0efcb89

File tree

11 files changed

+58
-53
lines changed

11 files changed

+58
-53
lines changed

‎plutus-benchmark/marlowe/src/PlutusBenchmark/Marlowe/Core/V1/Semantics/Types.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE DeriveAnyClass #-}
22
{-# LANGUAGE DeriveDataTypeable #-}
33
{-# LANGUAGE DerivingStrategies #-}
4+
{-# LANGUAGE DerivingVia #-}
45
{-# LANGUAGE MultiParamTypeClasses #-}
56
{-# LANGUAGE PatternSynonyms #-}
67
{-# LANGUAGE ScopedTypeVariables #-}

‎plutus-benchmark/plutus-benchmark.cabal‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,6 @@ common lang
5454
DeriveLift
5555
DeriveTraversable
5656
DerivingStrategies
57-
DerivingVia
5857
ExplicitForAll
5958
FlexibleContexts
6059
GeneralizedNewtypeDeriving

‎plutus-ledger-api/test-plugin/Spec/Budget.hs‎

Lines changed: 14 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
11
{-# LANGUAGE BangPatterns #-}
22
{-# LANGUAGE DataKinds #-}
3-
{-# LANGUAGE GADTs #-}
43
{-# LANGUAGE LambdaCase #-}
54
{-# LANGUAGE MultiParamTypeClasses #-}
65
{-# LANGUAGE NegativeLiterals #-}
@@ -13,7 +12,7 @@
1312

1413
module Spec.Budget where
1514

16-
import Test.Tasty (TestName, TestTree)
15+
import Test.Tasty (TestTree)
1716
import Test.Tasty.Extras
1817

1918
import Data.Bifunctor
@@ -31,12 +30,7 @@ tests =
3130
runTestNested ["test-plugin", "Spec", "Budget"] . pure . testNestedGhc $
3231
[ goldenPirReadable "gt" compiledGt
3332
, goldenPirReadable "currencySymbolValueOf" compiledCurrencySymbolValueOf
34-
]
35-
++ concatMap
36-
( \(TestCase name code) ->
37-
[ goldenEvalCekCatchBudget name code ]
38-
)
39-
testCases
33+
] ++ testCases
4034

4135
compiledGt :: CompiledCode (Value -> Value -> Bool)
4236
compiledGt = $$(compile [||gt||])
@@ -90,71 +84,69 @@ value3 =
9084
, (5, [(500, 501), (502, 503), (504, 505), (506, 507), (508, 509)])
9185
]
9286

93-
data TestCase = forall a. TestCase TestName (CompiledCode a)
94-
95-
testCases :: [TestCase]
87+
testCases :: [TestNested]
9688
testCases =
97-
[ TestCase
89+
[ goldenEvalCekCatchBudget
9890
"gt1"
9991
( compiledGt
10092
`unsafeApplyCode` liftCodeDef value1
10193
`unsafeApplyCode` liftCodeDef value1
10294
)
103-
, TestCase
95+
, goldenEvalCekCatchBudget
10496
"gt2"
10597
( compiledGt
10698
`unsafeApplyCode` liftCodeDef value1
10799
`unsafeApplyCode` liftCodeDef value2
108100
)
109-
, TestCase
101+
, goldenEvalCekCatchBudget
110102
"gt3"
111103
( compiledGt
112104
`unsafeApplyCode` liftCodeDef value2
113105
`unsafeApplyCode` liftCodeDef value1
114106
)
115-
, TestCase
107+
, goldenEvalCekCatchBudget
116108
"gt4"
117109
( compiledGt
118110
`unsafeApplyCode` liftCodeDef value1
119111
`unsafeApplyCode` liftCodeDef value3
120112
)
121-
, TestCase
113+
, goldenEvalCekCatchBudget
122114
"gt5"
123115
( compiledGt
124116
`unsafeApplyCode` liftCodeDef value3
125117
`unsafeApplyCode` liftCodeDef value1
126118
)
127-
, TestCase
119+
, goldenEvalCekCatchBudget
128120
"geq1"
129121
( compiledGeq
130122
`unsafeApplyCode` liftCodeDef value1
131123
`unsafeApplyCode` liftCodeDef value1
132124
)
133-
, TestCase
125+
, goldenEvalCekCatchBudget
134126
"geq2"
135127
( compiledGeq
136128
`unsafeApplyCode` liftCodeDef value1
137129
`unsafeApplyCode` liftCodeDef value2
138130
)
139-
, TestCase
131+
, goldenEvalCekCatchBudget
140132
"geq3"
141133
( compiledGeq
142134
`unsafeApplyCode` liftCodeDef value2
143135
`unsafeApplyCode` liftCodeDef value1
144136
)
145-
, TestCase
137+
, goldenEvalCekCatchBudget
146138
"geq4"
147139
( compiledGeq
148140
`unsafeApplyCode` liftCodeDef value1
149141
`unsafeApplyCode` liftCodeDef value3
150142
)
151-
, TestCase
143+
, goldenEvalCekCatchBudget
152144
"geq5"
153145
( compiledGeq
154146
`unsafeApplyCode` liftCodeDef value3
155147
`unsafeApplyCode` liftCodeDef value1
156148
)
157-
, TestCase
149+
, goldenEvalCekCatchBudget
158150
"currencySymbolValueOf"
159151
( compiledCurrencySymbolValueOf
160152
`unsafeApplyCode` liftCodeDef value2

‎plutus-ledger-api/test-plugin/Spec/Data/Budget.hs‎

Lines changed: 16 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
11
{-# LANGUAGE BangPatterns #-}
22
{-# LANGUAGE DataKinds #-}
3-
{-# LANGUAGE GADTs #-}
43
{-# LANGUAGE LambdaCase #-}
54
{-# LANGUAGE MultiParamTypeClasses #-}
65
{-# LANGUAGE NegativeLiterals #-}
@@ -13,7 +12,7 @@
1312

1413
module Spec.Data.Budget where
1514

16-
import Test.Tasty (TestName, TestTree)
15+
import Test.Tasty (TestTree)
1716
import Test.Tasty.Extras
1817

1918
import Data.Bifunctor
@@ -31,13 +30,7 @@ tests =
3130
runTestNested ["test-plugin", "Spec", "Data", "Budget"] . pure . testNestedGhc $
3231
[ goldenPirReadable "gt" compiledGt
3332
, goldenPirReadable "currencySymbolValueOf" compiledCurrencySymbolValueOf
34-
]
35-
++ concatMap
36-
( \(TestCase name code) ->
37-
[ goldenEvalCekCatchBudget name code
38-
]
39-
)
40-
testCases
33+
] ++ testCases
4134

4235
compiledGt :: CompiledCode (Value -> Value -> Bool)
4336
compiledGt = $$(compile [||gt||])
@@ -115,82 +108,80 @@ value4 =
115108
, (5, [(500, -501), (502, 503), (504, 505), (506, 507), (508, -509)])
116109
]
117110

118-
data TestCase = forall a. TestCase TestName (CompiledCode a)
119-
120-
testCases :: [TestCase]
111+
testCases :: [TestNested]
121112
testCases =
122-
[ TestCase
113+
[ goldenEvalCekCatchBudget
123114
"gt1"
124115
( compiledGt
125116
`unsafeApplyCode` liftCodeDef value1
126117
`unsafeApplyCode` liftCodeDef value1
127118
)
128-
, TestCase
119+
, goldenEvalCekCatchBudget
129120
"gt2"
130121
( compiledGt
131122
`unsafeApplyCode` liftCodeDef value1
132123
`unsafeApplyCode` liftCodeDef value2
133124
)
134-
, TestCase
125+
, goldenEvalCekCatchBudget
135126
"gt3"
136127
( compiledGt
137128
`unsafeApplyCode` liftCodeDef value2
138129
`unsafeApplyCode` liftCodeDef value1
139130
)
140-
, TestCase
131+
, goldenEvalCekCatchBudget
141132
"gt4"
142133
( compiledGt
143134
`unsafeApplyCode` liftCodeDef value1
144135
`unsafeApplyCode` liftCodeDef value3
145136
)
146-
, TestCase
137+
, goldenEvalCekCatchBudget
147138
"gt5"
148139
( compiledGt
149140
`unsafeApplyCode` liftCodeDef value3
150141
`unsafeApplyCode` liftCodeDef value1
151142
)
152-
, TestCase
143+
, goldenEvalCekCatchBudget
153144
"geq1"
154145
( compiledGeq
155146
`unsafeApplyCode` liftCodeDef value1
156147
`unsafeApplyCode` liftCodeDef value1
157148
)
158-
, TestCase
149+
, goldenEvalCekCatchBudget
159150
"geq2"
160151
( compiledGeq
161152
`unsafeApplyCode` liftCodeDef value1
162153
`unsafeApplyCode` liftCodeDef value2
163154
)
164-
, TestCase
155+
, goldenEvalCekCatchBudget
165156
"geq3"
166157
( compiledGeq
167158
`unsafeApplyCode` liftCodeDef value2
168159
`unsafeApplyCode` liftCodeDef value1
169160
)
170-
, TestCase
161+
, goldenEvalCekCatchBudget
171162
"geq4"
172163
( compiledGeq
173164
`unsafeApplyCode` liftCodeDef value1
174165
`unsafeApplyCode` liftCodeDef value3
175166
)
176-
, TestCase
167+
, goldenEvalCekCatchBudget
177168
"geq5"
178169
( compiledGeq
179170
`unsafeApplyCode` liftCodeDef value3
180171
`unsafeApplyCode` liftCodeDef value1
181172
)
182-
, TestCase
173+
, goldenEvalCekCatchBudget
183174
"currencySymbolValueOf"
184175
( compiledCurrencySymbolValueOf
185176
`unsafeApplyCode` liftCodeDef value2
186177
`unsafeApplyCode` liftCodeDef (toSymbol 6)
187178
)
188-
, TestCase
179+
, goldenEvalCekCatchBudget
189180
"mintValueMinted"
190181
( compiledMintValueMinted
191182
`unsafeApplyCode` liftCodeDef value4
192183
)
193-
, TestCase
184+
, goldenEvalCekCatchBudget
194185
"mintValueBurned"
195186
( compiledMintValueBurned
196187
`unsafeApplyCode` liftCodeDef value4

‎plutus-ledger-api/test-plugin/Spec/Data/ScriptContext.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
11
{-# LANGUAGE BangPatterns #-}
22
{-# LANGUAGE DataKinds #-}
3-
{-# LANGUAGE GADTs #-}
43
{-# LANGUAGE LambdaCase #-}
54
{-# LANGUAGE MultiParamTypeClasses #-}
65
{-# LANGUAGE NegativeLiterals #-}

‎plutus-ledger-api/test-plugin/Spec/ReturnUnit/V1.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
11
{-# LANGUAGE BangPatterns #-}
22
{-# LANGUAGE DataKinds #-}
3-
{-# LANGUAGE GADTs #-}
43
{-# LANGUAGE LambdaCase #-}
54
{-# LANGUAGE MultiParamTypeClasses #-}
65
{-# LANGUAGE NegativeLiterals #-}

‎plutus-ledger-api/test-plugin/Spec/ReturnUnit/V2.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
11
{-# LANGUAGE BangPatterns #-}
22
{-# LANGUAGE DataKinds #-}
3-
{-# LANGUAGE GADTs #-}
43
{-# LANGUAGE LambdaCase #-}
54
{-# LANGUAGE MultiParamTypeClasses #-}
65
{-# LANGUAGE NegativeLiterals #-}

‎plutus-ledger-api/test-plugin/Spec/ReturnUnit/V3.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
11
{-# LANGUAGE BangPatterns #-}
22
{-# LANGUAGE DataKinds #-}
3-
{-# LANGUAGE GADTs #-}
43
{-# LANGUAGE LambdaCase #-}
54
{-# LANGUAGE MultiParamTypeClasses #-}
65
{-# LANGUAGE NegativeLiterals #-}

‎plutus-tx-plugin/changelog.d/20250818_111253_me_7238.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
### Changed
2+
3+
- Compiliation will fail if `GADTs` or `PolyKinds` is used in the module. This is to providing better compilation error message. This also encourages clearer onchain/offchain separation by encouraging offchain components that uses `GADTs` or `PolyKinds` to be separated into a new module outside of onchain module.
4+

‎plutus-tx-plugin/src/PlutusTx/Plugin.hs‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE FlexibleContexts #-}
33
{-# LANGUAGE LambdaCase #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
45
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE TemplateHaskellQuotes #-}
67
{-# LANGUAGE TypeApplications #-}
@@ -70,8 +71,10 @@ import Data.ByteString qualified as BS
7071
import Data.ByteString.Unsafe qualified as BSUnsafe
7172
import Data.Either.Validation
7273
import Data.Map qualified as Map
74+
import Data.Maybe (mapMaybe)
7375
import Data.Monoid.Extra (mwhen)
7476
import Data.Set qualified as Set
77+
import Data.Text qualified as Text
7578
import GHC.Num.Integer qualified
7679
import PlutusCore.Default (DefaultFun, DefaultUni)
7780
import PlutusIR.Compiler.Provenance (noProvenance, original)
@@ -488,6 +491,26 @@ runCompiler
488491
-> GHC.CoreExpr
489492
-> m (PIRProgram uni fun, UPLCProgram uni fun)
490493
runCompiler moduleName opts expr = do
494+
GHC.DynFlags {GHC.extensions = extensions} <- asks ccFlags
495+
let
496+
enabledExtensions =
497+
mapMaybe
498+
(\case
499+
GHC.On a -> Just a
500+
GHC.Off _ -> Nothing)
501+
extensions
502+
extensionBlacklist =
503+
[ GADTs
504+
, PolyKinds
505+
]
506+
unsupportedExtensions =
507+
filter (`elem` extensionBlacklist) enabledExtensions
508+
509+
when (not $ null unsupportedExtensions) $
510+
throwPlain $ UnsupportedError $
511+
"Following extensions are not supported: "
512+
<> Text.intercalate ", " (Text.pack . show <$> unsupportedExtensions)
513+
491514
-- Plc configuration
492515
plcTcConfig <-
493516
modifyError (NoContext . PIRError . PIR.PLCTypeError) $

0 commit comments

Comments
 (0)