summaryrefslogtreecommitdiff
path: root/Proof/Internal/THCompat.hs
blob: 61d59300a213fd5ef64d1a64d63822eba19f91bd (plain)
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
{-# LANGUAGE CPP, PatternSynonyms, TemplateHaskell, ViewPatterns #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
module Proof.Internal.THCompat where
import Language.Haskell.TH
import Language.Haskell.TH.Extras

import GHC.Exts (Constraint)

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 802
import GHC.Generics
import Data.Data
#endif

#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 802
data DerivClause = DerivClause (Maybe DerivStrategy) Cxt
                 deriving (Eq, Data, Ord, Show, Generic)
data  DerivStrategy = StockStrategy
                    | AnyclassStrategy
                    | NewtypeStrategy
                    deriving (Eq, Data, Ord, Show, Generic)
#endif

dcToNames :: DerivClause -> [Name]
dcToNames (DerivClause _ ct) = map headOfType ct

dcToCxt :: DerivClause -> Cxt
dcToCxt (DerivClause _ ct) = ct


mkDataD :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [DerivClause] -> Dec
mkDataD ctx name tvbndrs cons dc =
  DataD ctx name tvbndrs
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
        Nothing cons 
#if __GLASGOW_HASKELL__ < 802
        (concatMap dcToCxt dc)
#else
        dc
#endif
#else
        cons (concatMap dcToNames dc)
#endif


typeName :: Type -> Name
typeName (VarT n) = n
typeName (ConT n) = n
typeName (PromotedT n) = n
typeName (TupleT n) = tupleTypeName n
typeName (UnboxedTupleT n) = unboxedTupleTypeName n
typeName ArrowT = ''(->)
typeName EqualityT = ''(~)
typeName ListT = ''[]
typeName (PromotedTupleT n) = tupleDataName n
typeName PromotedNilT = '[]
typeName PromotedConsT = '(:)
typeName ConstraintT = ''Constraint
typeName _ = error "No names!"

pattern DataDCompat :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [DerivClause] -> Dec
pattern DataDCompat ctx name tvbndrs cons dcs <-
  DataD ctx name tvbndrs
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
        _ cons 
#if __GLASGOW_HASKELL__ < 802
        (pure . DerivClause Nothing -> dcs)
#else 
        dcs
#endif
#else
        cons (DerivClause Nothing . map ConT -> dc)
#endif

pattern NewtypeDCompat :: Cxt -> Name -> [TyVarBndr] -> Con -> [DerivClause] -> Dec
pattern NewtypeDCompat ctx name tvbndrs con dcs <-
  NewtypeD ctx name tvbndrs
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800
        _ con
#if __GLASGOW_HASKELL__ < 802
        (pure . DerivClause Nothing -> dcs)
#else
        dcs
#endif
#else
        con
        (DerivClause Nothing . map ConT -> dcs)
#endif