/
Spec.hs
88 lines (66 loc) · 3.47 KB
/
Spec.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fplugin PlutusTx.Plugin -fplugin-opt PlutusTx.Plugin:defer-errors -fplugin-opt PlutusTx.Plugin:no-context #-}
module Plugin.Errors.Spec where
import Common
import Lib
import PlcTestUtils
import Plugin.Lib
import qualified PlutusTx.Builtins as Builtins
import PlutusTx.Code
import PlutusTx.Plugin
import qualified PlutusCore.Default as PLC
import Data.Proxy
import Data.String
-- Normally GHC will irritatingly case integers for us in some circumstances, but we want to do it
-- explicitly here, so we need to see the constructors.
import GHC.Integer.GMP.Internals
-- this module does lots of weird stuff deliberately
{-# ANN module ("HLint: ignore"::String) #-}
errors :: TestNested
errors = testNested "Errors" [
goldenUPlcCatch "machInt" machInt
-- FIXME: This fails differently in nix, possibly due to slightly different optimization settings
-- , goldenPlcCatch "negativeInt" negativeInt
, goldenUPlcCatch "caseInt" caseInt
, goldenUPlcCatch "recursiveNewtype" recursiveNewtype
, goldenUPlcCatch "mutualRecursionUnfoldingsLocal" mutualRecursionUnfoldingsLocal
, goldenUPlcCatch "literalCaseInt" literalCaseInt
, goldenUPlcCatch "literalConcatenateBs" literalConcatenateBs
, goldenUPlcCatch "literalCaseOther" literalCaseOther
]
machInt :: CompiledCode Int
machInt = plc (Proxy @"machInt") (1::Int)
negativeInt :: CompiledCode Integer
negativeInt = plc (Proxy @"negativeInt") (-1 :: Integer)
caseInt :: CompiledCode (Integer -> Bool)
caseInt = plc (Proxy @"caseInt") (\(i::Integer) -> case i of { S# i -> True; _ -> False; } )
newtype RecursiveNewtype = RecursiveNewtype [RecursiveNewtype]
recursiveNewtype :: CompiledCode (RecursiveNewtype)
recursiveNewtype = plc (Proxy @"recursiveNewtype") (RecursiveNewtype [])
{-# INLINABLE evenDirectLocal #-}
evenDirectLocal :: Integer -> Bool
evenDirectLocal n = if Builtins.equalsInteger n 0 then True else oddDirectLocal (Builtins.subtractInteger n 1)
{-# INLINABLE oddDirectLocal #-}
oddDirectLocal :: Integer -> Bool
oddDirectLocal n = if Builtins.equalsInteger n 0 then False else evenDirectLocal (Builtins.subtractInteger n 1)
-- FIXME: these seem to only get unfoldings when they're in a separate module, even with the simplifier pass
mutualRecursionUnfoldingsLocal :: CompiledCode Bool
mutualRecursionUnfoldingsLocal = plc (Proxy @"mutualRecursionUnfoldingsLocal") (evenDirectLocal 4)
literalCaseInt :: CompiledCode (Integer -> Integer)
literalCaseInt = plc (Proxy @"literalCaseInt") (\case { 1 -> 2; x -> x})
literalConcatenateBs :: CompiledCode (Builtins.ByteString -> Builtins.ByteString)
literalConcatenateBs = plc (Proxy @"literalConcatenateBs") (\x -> Builtins.concatenate "hello" x)
data AType = AType
instance IsString AType where
fromString _ = AType
instance Eq AType where
AType == AType = True
-- Unfortunately, this actually succeeds, since the match gets turned into an equality and we can actually inline it.
-- I'm leaving it here since I'd really prefer it were an error for consistency, but I'm not sure how to do that nicely.
literalCaseOther :: CompiledCode (AType -> AType)
literalCaseOther = plc (Proxy @"literalCaseOther") (\x -> case x of { "abc" -> ""; x -> x})