Context.hs 1.86 KB
Newer Older
1
2
3
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
Sven Keidel's avatar
Sven Keidel committed
4
5
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
6
7
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
Sven Keidel's avatar
Sven Keidel committed
8
{-# LANGUAGE TypeFamilies #-}
9
{-# LANGUAGE UnboxedTuples #-}
Sven Keidel's avatar
Sven Keidel committed
10
11
12
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Transformer.Abstract.Fix.Context where

13
import Prelude hiding (lookup,truncate,(.),id)
Sven Keidel's avatar
Sven Keidel committed
14
15
16

import Control.Category
import Control.Arrow
17
import Control.Arrow.Primitive
18
import Control.Arrow.Strict
19
import Control.Arrow.Fix.ControlFlow
Sven Keidel's avatar
Sven Keidel committed
20
import Control.Arrow.Fix.Context
21
import Control.Arrow.Fix.Cache as Cache
Sven Keidel's avatar
Sven Keidel committed
22
23
24
25
26
27
28
29
import Control.Arrow.Trans
import Control.Arrow.Reader

import Control.Arrow.Transformer.Reader

import Data.Profunctor.Unsafe
import Data.Coerce
import Data.Empty
30

31
newtype ContextT ctx c x y = ContextT (ReaderT ctx c x y)
32
  deriving (Category,Profunctor,Arrow,ArrowChoice,ArrowStrict,
Tomislav Pree's avatar
Tomislav Pree committed
33
            ArrowLift,ArrowControlFlow stmt, ArrowPrimitive, ArrowCFG graph)
34

35
36
37
runContextT :: (IsEmpty ctx, Profunctor c) => ContextT ctx c x y -> c x y
runContextT (ContextT f) = lmap (empty,) (runReaderT f)
{-# INLINE runContextT #-}
Sven Keidel's avatar
Sven Keidel committed
38

39
instance (Arrow c, Profunctor c) => ArrowContext ctx (ContextT ctx c) where
Sven Keidel's avatar
Sven Keidel committed
40
41
42
43
44
  askContext = ContextT ask
  localContext (ContextT f) = ContextT (local f)
  {-# INLINE askContext #-}
  {-# INLINE localContext #-}

45
instance ArrowTrans (ContextT ctx) where
46
  lift' = ContextT . lift'
47
48
  {-# INLINE lift' #-}

49
50
instance (IsEmpty ctx, ArrowRun c) => ArrowRun (ContextT ctx c) where
  type Run (ContextT ctx c) x y = Run c x y
Sven Keidel's avatar
Sven Keidel committed
51
52
53
  run f = run (runContextT f)
  {-# INLINE run #-}

54
55
instance ArrowCache a b c => ArrowCache a b (ContextT ctx c) where
  type Widening (ContextT ctx c) = Cache.Widening c
Sven Keidel's avatar
Sven Keidel committed
56

57
instance (Profunctor c,ArrowApply c) => ArrowApply (ContextT ctx c) where
Sven Keidel's avatar
Sven Keidel committed
58
59
  app = ContextT (app .# first coerce)
  {-# INLINE app #-}