Fix.hs 2.67 KB
Newer Older
1
{-# LANGUAGE DataKinds #-}
2
3
4
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
Sven Keidel's avatar
Sven Keidel committed
5
{-# LANGUAGE ImplicitParams #-}
6
{-# LANGUAGE MultiParamTypeClasses #-}
7
{-# LANGUAGE RankNTypes #-}
8
{-# LANGUAGE TypeFamilies #-}
9
{-# LANGUAGE UnboxedTuples #-}
10
11
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
Tomislav Pree's avatar
Tomislav Pree committed
12
module Control.Arrow.Transformer.Abstract.Fix(FixT(..),runFixT) where
13
14
15
16
17

import           Prelude hiding (id,(.),const,head,iterate,lookup)

import           Control.Category
import           Control.Arrow hiding (loop)
18
import           Control.Arrow.Primitive
19
import           Control.Arrow.Strict
20
import           Control.Arrow.Fix
Sven Keidel's avatar
Sven Keidel committed
21
22
import           Control.Arrow.Fix.Cache
import           Control.Arrow.Fix.Chaotic
23
import           Control.Arrow.Fix.ControlFlow
Sven Keidel's avatar
Sven Keidel committed
24
25
import           Control.Arrow.Fix.Context
import           Control.Arrow.Fix.Metrics
26
import           Control.Arrow.Fix.Stack
Sven Keidel's avatar
Sven Keidel committed
27
import           Control.Arrow.Order(ArrowComplete(..),ArrowJoin(..))
28
29
30
31
32
import           Control.Arrow.Trans

import           Data.Profunctor
import           Data.Profunctor.Unsafe((.#))
import           Data.Coerce
Sven Keidel's avatar
Sven Keidel committed
33
import           Data.Order hiding (lub)
34

Tomislav Pree's avatar
Tomislav Pree committed
35
36
import           Control.Arrow.State

Sven Keidel's avatar
Sven Keidel committed
37
38
newtype FixT c x y = FixT (c x y)
  deriving (Profunctor,Category,Arrow,ArrowChoice,
39
            ArrowContext ctx, ArrowJoinContext a, ArrowControlFlow a,
Sven Keidel's avatar
Sven Keidel committed
40
            ArrowCache a b, ArrowParallelCache a b, ArrowIterateCache a b, ArrowGetCache cache,
Sven Keidel's avatar
Sven Keidel committed
41
42
            ArrowStack a,ArrowStackElements a,ArrowStackDepth,
            ArrowComponent a, ArrowInComponent a,
Tomislav Pree's avatar
Tomislav Pree committed
43
            ArrowMetrics a, ArrowStrict, ArrowPrimitive, ArrowCFG a)
Sven Keidel's avatar
Sven Keidel committed
44
45
46

runFixT :: FixT c x y -> c x y
runFixT (FixT f) = f
47
48
{-# INLINE runFixT #-}

Sven Keidel's avatar
Sven Keidel committed
49
50
51
instance ArrowRun c => ArrowRun (FixT c) where
  type Run (FixT c) x y = Run c x y

52
instance ArrowLift (FixT c) where
Sven Keidel's avatar
Sven Keidel committed
53
  type Underlying (FixT c) x y = c x y
54

Sven Keidel's avatar
Sven Keidel committed
55
56
instance ArrowFix (FixT c a b) where
  type Fix (FixT c a b) = FixT c a b
Sven Keidel's avatar
Sven Keidel committed
57
  fix = ?fixpointAlgorithm
58
  {-# INLINE fix #-}
59
  {-# SCC fix #-}
60

Sven Keidel's avatar
Sven Keidel committed
61
instance (Profunctor c,ArrowApply c) => ArrowApply (FixT c) where
62
63
64
  app = FixT (app .# first coerce)
  {-# INLINE app #-}

65
instance ArrowTrans FixT where
Sven Keidel's avatar
Sven Keidel committed
66
  lift' = FixT
67
  {-# INLINE lift' #-}
Sven Keidel's avatar
Sven Keidel committed
68
69
70
71
72
73
74

instance (Complete y, Profunctor c, Arrow c) => ArrowComplete y (FixT c) where
  FixT f <> FixT g = FixT (rmap (uncurry ()) (f &&& g))
  {-# INLINE (<⊔>) #-}

instance (Profunctor c, Arrow c) => ArrowJoin (FixT c) where
  joinSecond lub f (FixT g) = FixT (dimap (\x -> (x, x)) (\(x,y) -> (lub (f x) y)) (second g))
Tomislav Pree's avatar
Tomislav Pree committed
75
76
77
78
79
80
81

instance ArrowState s c => ArrowState s (FixT c) where
  get = lift get
  put = lift put
  {-# INLINE get #-}
  {-# INLINE put #-}