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
89
90
91
92
93
94
95
96
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
-- base
import Control.Monad
( forM_ )
import Control.Monad.IO.Class
( liftIO )
import System.Environment
( getArgs )
-- ghc
import GHC
( runGhc
, getSessionDynFlags, setSessionDynFlags
, getLogger
)
import GHC.Builtin.Types
( intTy
, liftedDataConTy, liftedRepTy
)
import GHC.Builtin.PrimOps
( PrimOp(RaiseOp) )
import GHC.Builtin.PrimOps.Ids
( primOpId )
import GHC.Builtin.Types.Prim
( runtimeRep1Ty, runtimeRep1TyVar
, openAlphaTy, openAlphaTyVar
)
import GHC.Core
( CoreExpr, Expr(Var, Type)
, mkApps
)
import GHC.Core.Lint
( lintExpr )
import GHC.Core.Type
( mkVisFunTyMany )
import GHC.Driver.Config.Core.Lint
import GHC.Driver.Session
( GeneralFlag(Opt_SuppressUniques), gopt_set )
import GHC.Types.Id.Make
( coerceId )
import GHC.Types.Var ( Id )
import GHC.Utils.Error
( pprMessageBag, putMsg )
import GHC.Utils.Outputable
( (<+>), ($$), text )
--------------------------------------------------------------------------------
test_exprs :: [ ( String, CoreExpr ) ]
test_exprs =
[ ("coerce OK", ) $
-- coerce @LiftedRep
mkApps (Var coerceId)
[ Type liftedRepTy ]
, ("coerce BAD 1", ) $
-- coerce
mkApps (Var coerceId) []
, ("coerce BAD 2", ) $
-- coerce @r
mkApps (Var coerceId)
[ Type runtimeRep1Ty ]
, ("raise# OK", ) $
-- raise# @Lifted @LiftedRep @Int @(z -> z), where z :: TYPE r
mkApps (Var $ primOpId RaiseOp)
[ Type liftedDataConTy
, Type liftedRepTy
, Type intTy
, Type $ mkVisFunTyMany openAlphaTy openAlphaTy
]
]
-- These will be considered in-scope by the Core Lint checks.
in_scope :: [ Id ]
in_scope = [ runtimeRep1TyVar, openAlphaTyVar ]
main :: IO ()
main = do
[libdir] <- getArgs
runGhc (Just libdir) do
getSessionDynFlags >>= setSessionDynFlags . flip gopt_set Opt_SuppressUniques
dflags <- getSessionDynFlags
logger <- getLogger
liftIO do
forM_ test_exprs \ ( test_name, expr ) ->
forM_ ( lintExpr (initLintConfig dflags in_scope) expr ) \ errs ->
putMsg logger
( pprMessageBag errs $$ text "in" <+> text test_name )
|
