SomeFunctor.hs 3.31 KB
Newer Older
1
{-# LANGUAGE BangPatterns #-}
2
3
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
4
{-# LANGUAGE FlexibleInstances #-}
5
{-# LANGUAGE Strict #-}
6
module MA.Functors.SomeFunctor
7
8
9
10
11
12
13
  ( SomeFunctor
  , someFunctor
  ) where

import Prelude hiding (init)

import Type.Reflection
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
14
import Data.Maybe (mapMaybe)
15

16
import Control.DeepSeq (NFData(..))
17
18
import           Data.Vector (Vector)
import qualified Data.Vector as V
19

20
import MA.RefinementInterface
21
22
import MA.Coalgebra.RefinementTypes
import MA.FunctorExpression.Parser
23
import MA.Coalgebra.Parser.Class
24

25
type Suitable f = (RefinementInterface f, Functor f, Foldable f, Traversable f, NFData (H1 f), NFData (Label f))
26

27
28
data SomeFunctor a where
  SomeFunctor
29
    :: (Suitable f, Typeable f, ParseMorphism f)
30
31
32
33
34
35
36
37
    => f a
    -> SomeFunctor a

deriving instance Functor SomeFunctor
deriving instance Foldable SomeFunctor
deriving instance Traversable SomeFunctor

someFunctor ::
38
     (Suitable f, Typeable f, ParseMorphism f)
39
40
41
42
43
  => FunctorParser f
  -> FunctorParser SomeFunctor
someFunctor = transParser SomeFunctor

data SomeLabel where
44
45
46
47
  SomeLabel :: (Suitable f) => TypeRep f -> Label f -> SomeLabel

instance NFData SomeLabel where
  rnf (SomeLabel !_ !inner) = rnf inner
48
49

data SomeWeight where
50
  SomeWeight :: Suitable f => TypeRep f -> Weight f -> SomeWeight
51
52

data SomeH1 where
53
  SomeH1 :: (Suitable f) => TypeRep f -> H1 f -> SomeH1
54
55
56
57
58
59
60
61
62
63
64

instance Eq SomeH1 where
  (SomeH1 f1 a) == (SomeH1 f2 b) = case eqTypeRep f1 f2 of
    Nothing -> False
    Just HRefl -> a == b

instance Ord SomeH1 where
  compare (SomeH1 f1 a) (SomeH1 f2 b) = case eqTypeRep f1 f2 of
    Nothing -> compare @Int 1 2 -- XXX: should not happen
    Just HRefl -> compare a b

65
66
67
instance NFData SomeH1 where
  rnf (SomeH1 !_ !inner) = rnf inner

68
data SomeH3 where
69
  SomeH3 :: Suitable f => TypeRep f -> H3 f -> SomeH3
70
71
72
73
74
75
76
77
78
79
80

instance Eq SomeH3 where
  (SomeH3 f1 a) == (SomeH3 f2 b) = case eqTypeRep f1 f2 of
    Nothing -> False
    Just HRefl -> a == b

instance Ord SomeH3 where
  compare (SomeH3 f1 a) (SomeH3 f2 b) = case eqTypeRep f1 f2 of
    Nothing -> compare @Int 1 2 -- XXX: should not happen
    Just HRefl -> compare a b

81
82
83
84
type instance Label SomeFunctor = SomeLabel
type instance Weight SomeFunctor = SomeWeight
type instance H1 SomeFunctor = SomeH1
type instance H3 SomeFunctor = SomeH3
85

86
instance RefinementInterface SomeFunctor where
87
  init (SomeH1 (f :: TypeRep tf) h1) labels =
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
88
    let myLabels = mapMaybe isSameType labels
89
90
91
92
93
94
95
96
    in SomeWeight f (init @tf h1 myLabels)

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

97
98
99
  update labels (SomeWeight (f :: TypeRep tf) w) = {-# SCC thefuck #-}
    let myLabels = (mapMaybe $! isSameType) $! labels
        (a, b, c) = (update @tf $! myLabels) $! w
100
101
102
103
104
105
106
    in (SomeWeight f a, SomeH3 f b, SomeWeight f c)

    where
      isSameType :: SomeLabel -> Maybe (Label tf)
      isSameType (SomeLabel f2 l) = case eqTypeRep f f2 of
        Nothing -> Nothing
        Just HRefl -> Just l
107
108

instance ParseMorphism SomeFunctor where
109
  parseMorphismPoint (SomeFunctor (f :: tf (MorphParser l h1 x))) = do
110
111
112
    (h1, succs) <- parseMorphismPoint f
    let fRep = typeRep @tf
        newH1 = SomeH1 fRep h1
113

114
115
116
    let newSuccs = V.map (\(x, y) -> (x, SomeLabel fRep y)) succs

    return (newH1, newSuccs)