SomeFunctor.hs 6.16 KB
Newer Older
1
2
{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
3
{-# LANGUAGE BangPatterns #-}
4
5
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
6
{-# LANGUAGE FlexibleInstances #-}
7
{-# LANGUAGE Strict #-}
8

9
module Copar.Functors.SomeFunctor
10
  ( SomeFunctor(..)
11
  , Suitable
12
  , transformInner
13
14
  , someFunctorExprParser
  , dynFunctorExprParser
15
16
  , SomeWeight(..)
  , SomeLabel
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
17
  , SomeF1
18
19
  ) where

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
20
import           Prelude hiding (init)
21

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
22
import           Type.Reflection
23
24
25
26
#ifdef RELEASE
import           GHC.Exts (Any)
import           Unsafe.Coerce
#else
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
27
import           Data.Maybe (mapMaybe)
28
#endif
29
import           Data.Functor.Classes
30
import           Data.Proxy
31

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
32
import           Control.DeepSeq (NFData(..))
33
import qualified Data.Vector as V
34
import qualified Data.Text as T
35

36
import           Copar.Coalgebra.Parser.Class
37
import           Copar.FunctorExpression.Printable
38
39
import           Copar.FunctorExpression.Parser

40
41
import           Copar.PrettyShow
import           Copar.RefinementInterface
42
import           Copar.FunctorDescription
43

44

45
46
data SomeFunctor a where
  SomeFunctor
47
    :: Suitable f
48
    => f a
49
50
    -> SomeFunctor a

51
52
53
54
55
56
57
58
59
someFunctorExprParser :: DynFunctorDescription -> FunctorParser SomeFunctor
someFunctorExprParser (DynFunctorDescription (Proxy :: Proxy f)) = transParser SomeFunctor (functorExprParser @f)

instance ToDynFunctorDescription SomeFunctor where
  toDynFunctorDescription (SomeFunctor (_ :: f a)) = DynFunctorDescription (Proxy :: Proxy f)

dynFunctorExprParser :: DynFunctorDescription -> FunctorParser SomeFunctor
dynFunctorExprParser (DynFunctorDescription (Proxy :: Proxy f)) = transParser SomeFunctor (functorExprParser @f)

60
61
62
63
deriving instance Functor SomeFunctor
deriving instance Foldable SomeFunctor
deriving instance Traversable SomeFunctor

Bastian Kauschke's avatar
Bastian Kauschke committed
64
65
66
instance Show a => Show (SomeFunctor a) where
  showsPrec = showsPrec1

67
instance Show1 SomeFunctor where
68
  liftShowsPrec shows' showsList' pred (SomeFunctor f) =
69
    liftShowsPrec shows' showsList' pred f
70

Bastian Kauschke's avatar
Bastian Kauschke committed
71
72
73
instance Eq a => Eq (SomeFunctor a) where
  (==) = eq1

74
75
76
77
78
79
instance Eq1 SomeFunctor where
  liftEq eq' (SomeFunctor (lhs :: f' a)) (SomeFunctor (rhs :: f'' b)) =
    case eqTypeRep (typeRep @f') (typeRep @f'') of
      Nothing    -> False
      Just HRefl -> liftEq eq' lhs rhs

80
instance Printable SomeFunctor where
Bastian Kauschke's avatar
Bastian Kauschke committed
81
  printMe cfg (SomeFunctor x) = printMe cfg x
82

83
84
85
86
87
88
89
-- | Apply a natural transformation under the 'SomeFunctor'.
--
-- This can change the functor stored in the 'SomeFunctor'. Transformations with
-- the wrong domain are silently ignored.
transformInner
  :: forall f g a
   . (Typeable f, Typeable g, Suitable g, ParseMorphism g)
90
  => (f a -> Maybe (g a))
91
92
93
94
  -> SomeFunctor a
  -> SomeFunctor a
transformInner t (SomeFunctor (x :: f1 a)) =
  case eqTypeRep (typeRep @f) (typeRep @f1) of
95
    Nothing    -> SomeFunctor x
96
97
98
    Just HRefl -> case t x of
      Nothing  -> SomeFunctor x
      Just new -> SomeFunctor new
99

100
101
102
103
104
105
106
107
-- A note on all this Any stuff:
--
-- It's safe to unsafeCoerce a type to Any and than coerce it back, but what we
-- do here is actually "unsafeCoerce :: [Any] -> [Label]" instead of the more
-- obviously safe "map (unsafeCoerce :: Any -> Label)". According to #haskell,
-- it's "about as safe".


108
109
110
111
112
#ifdef RELEASE
newtype SomeLabel = SomeLabel Any

instance PrettyShow SomeLabel where
  prettyShow _ = "[elided]"
113
114
115

instance NFData SomeLabel where
  rnf (SomeLabel inner) = inner `seq` ()
116
#else
117
data SomeLabel where
118
119
  SomeLabel :: (Suitable f) => TypeRep f -> Label f -> SomeLabel

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
120
121
122
instance PrettyShow SomeLabel where
  prettyShow (SomeLabel _ inner) = prettyShow inner

123
124
instance NFData SomeLabel where
  rnf (SomeLabel !_ !inner) = rnf inner
125
#endif
126

127
128
129
instance Show SomeLabel where
  show = T.unpack . prettyShow

130
131

data SomeWeight where
132
  SomeWeight :: Suitable f => TypeRep f -> Weight f -> SomeWeight
133

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
134
135
data SomeF1 where
  SomeF1 :: (Suitable f) => TypeRep f -> F1 f -> SomeF1
136

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
137
138
instance Eq SomeF1 where
  (SomeF1 f1 a) == (SomeF1 f2 b) = case eqTypeRep f1 f2 of
139
140
141
    Nothing -> False
    Just HRefl -> a == b

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
142
143
instance Ord SomeF1 where
  compare (SomeF1 f1 a) (SomeF1 f2 b) = case eqTypeRep f1 f2 of
144
145
146
    Nothing -> compare @Int 1 2 -- XXX: should not happen
    Just HRefl -> compare a b

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
147
148
instance PrettyShow SomeF1 where
  prettyShow (SomeF1 _ a) = prettyShow a
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
149

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
150
instance Show SomeF1 where
151
152
  show = T.unpack . prettyShow

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
153
154
instance NFData SomeF1 where
  rnf (SomeF1 !_ !inner) = rnf inner
155

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
156
157
data SomeF3 where
  SomeF3 :: Suitable f => TypeRep f -> F3 f -> SomeF3
158

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
159
160
instance Eq SomeF3 where
  (SomeF3 f1 a) == (SomeF3 f2 b) = case eqTypeRep f1 f2 of
161
162
163
    Nothing -> False
    Just HRefl -> a == b

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
164
165
instance Ord SomeF3 where
  compare (SomeF3 f1 a) (SomeF3 f2 b) = case eqTypeRep f1 f2 of
166
167
168
    Nothing -> compare @Int 1 2 -- XXX: should not happen
    Just HRefl -> compare a b

169
170
type instance Label SomeFunctor = SomeLabel
type instance Weight SomeFunctor = SomeWeight
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
171
172
type instance F1 SomeFunctor = SomeF1
type instance F3 SomeFunctor = SomeF3
173

174
instance RefinementInterface SomeFunctor where
175
  init (SomeF1 (f :: TypeRep tf) f1) labels =
176
#ifdef RELEASE
177
    SomeWeight f (init @tf f1 (unsafeCoerce labels))
178
#else
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
179
    let myLabels = mapMaybe isSameType labels
180
    in SomeWeight f (init @tf f1 myLabels)
181
182
183
184
185
186

    where
      isSameType :: SomeLabel -> Maybe (Label tf)
      isSameType (SomeLabel f2 l) = case eqTypeRep f f2 of
        Nothing -> Nothing
        Just HRefl -> Just l
187
#endif
188
189

  update labels (SomeWeight (f :: TypeRep tf) w) =
190
191
#ifdef RELEASE
    let (a, b, c) = update @tf (unsafeCoerce labels) w
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
192
    in (SomeWeight f a, SomeF3 f b, SomeWeight f c)
193
#else
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
194
    let myLabels = mapMaybe isSameType labels
195
        (a, b, c) = update @tf myLabels w
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
196
    in (SomeWeight f a, SomeF3 f b, SomeWeight f c)
197
198
199
200
201
202

    where
      isSameType :: SomeLabel -> Maybe (Label tf)
      isSameType (SomeLabel f2 l) = case eqTypeRep f f2 of
        Nothing -> Nothing
        Just HRefl -> Just l
203
#endif
204
205

instance ParseMorphism SomeFunctor where
206
207
  parseMorphismPoint (SomeFunctor (f :: tf (MorphParser l f1 x))) = do
    (f1, succs) <- parseMorphismPoint f
208
    let fRep = typeRep @tf
209
        newF1 = SomeF1 fRep f1
210

211
212
213
#ifdef RELEASE
    let newSuccs = V.map (\(x, y) -> (x, unsafeCoerce y)) succs
#else
214
    let newSuccs = V.map (\(x, y) -> (x, SomeLabel fRep y)) succs
215
#endif
216

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
217
    return (newF1, newSuccs)