Orphan.hs

{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Array.Knead.Shape.Orphan where

import qualified Data.Array.Knead.Expression as Expr

import qualified Data.Array.Comfort.Shape as Shape
import Data.Array.Comfort.Shape
         (ZeroBased(ZeroBased), Range(Range), Shifted(Shifted),
          Cyclic(Cyclic),
          Enumeration(Enumeration))

import qualified LLVM.Extra.Nice.Value.Marshal as Marshal
import qualified LLVM.Extra.Nice.Value as NiceValue
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Tuple as Tuple

import qualified Control.Monad.HT as Monad
import Control.Applicative ((<$>))

import Prelude2010
import Prelude ()



unzipZeroBased :: NiceValue.T (ZeroBased n) -> ZeroBased (NiceValue.T n)
unzipZeroBased (NiceValue.Cons (ZeroBased n)) = ZeroBased (NiceValue.Cons n)

zeroBasedSize :: (Expr.Value val) => val (ZeroBased n) -> val n
zeroBasedSize = Expr.lift1 $ Shape.zeroBasedSize . unzipZeroBased

zeroBased :: (Expr.Value val) => val n -> val (ZeroBased n)
zeroBased = Expr.lift1 $ \(NiceValue.Cons n) -> NiceValue.Cons (ZeroBased n)

instance (Tuple.Undefined n) => Tuple.Undefined (ZeroBased n) where
   undef = ZeroBased Tuple.undef

instance (Tuple.Phi n) => Tuple.Phi (ZeroBased n) where
   phi bb = fmap ZeroBased . Tuple.phi bb . Shape.zeroBasedSize
   addPhi bb (Shape.ZeroBased a) (Shape.ZeroBased b) = Tuple.addPhi bb a b

instance (Tuple.Value n) => Tuple.Value (ZeroBased n) where
   type ValueOf (ZeroBased n) = ZeroBased (Tuple.ValueOf n)
   valueOf (ZeroBased n) = ZeroBased $ Tuple.valueOf n

instance (NiceValue.C n) => NiceValue.C (ZeroBased n) where
   type Repr (ZeroBased n) = ZeroBased (NiceValue.Repr n)
   cons (ZeroBased n) = zeroBased (NiceValue.cons n)
   undef = zeroBased NiceValue.undef
   zero = zeroBased NiceValue.zero
   phi bb = Monad.lift zeroBased . NiceValue.phi bb . zeroBasedSize
   addPhi bb a b = NiceValue.addPhi bb (zeroBasedSize a) (zeroBasedSize b)

type instance
   NiceValue.Decomposed f (ZeroBased pn) =
      ZeroBased (NiceValue.Decomposed f pn)
type instance
   NiceValue.PatternTuple (ZeroBased pn) =
      ZeroBased (NiceValue.PatternTuple pn)

instance (NiceValue.Compose n) => NiceValue.Compose (ZeroBased n) where
   type Composed (ZeroBased n) = ZeroBased (NiceValue.Composed n)
   compose (ZeroBased n) = zeroBased (NiceValue.compose n)

instance (NiceValue.Decompose pn) => NiceValue.Decompose (ZeroBased pn) where
   decompose (ZeroBased p) sh =
      NiceValue.decompose p <$> unzipZeroBased sh

instance (Expr.Compose n) => Expr.Compose (ZeroBased n) where
   type Composed (ZeroBased n) = ZeroBased (Expr.Composed n)
   compose (ZeroBased n) = Expr.lift1 zeroBased (Expr.compose n)

instance (Expr.Decompose pn) => Expr.Decompose (ZeroBased pn) where
   decompose (ZeroBased p) = ZeroBased . Expr.decompose p . zeroBasedSize

instance (Memory.C n) => Memory.C (ZeroBased n) where
   type Struct (ZeroBased n) = Memory.Struct n
   compose = Memory.compose . Shape.zeroBasedSize
   decompose = fmap ZeroBased . Memory.decompose

instance (Marshal.C n) => Marshal.C (ZeroBased n) where
   pack = Marshal.pack . Shape.zeroBasedSize
   unpack = Shape.ZeroBased . Marshal.unpack



singletonRange :: n -> Range n
singletonRange n = Range n n

unzipRange :: NiceValue.T (Range n) -> Range (NiceValue.T n)
unzipRange (NiceValue.Cons (Range from to)) =
   Range (NiceValue.Cons from) (NiceValue.Cons to)

zipRange :: NiceValue.T n -> NiceValue.T n -> NiceValue.T (Range n)
zipRange (NiceValue.Cons from) (NiceValue.Cons to) =
   NiceValue.Cons (Range from to)

instance (Tuple.Undefined n) => Tuple.Undefined (Range n) where
   undef = Range Tuple.undef Tuple.undef

instance (Tuple.Value n) => Tuple.Value (Range n) where
   type ValueOf (Range n) = Range (Tuple.ValueOf n)
   valueOf (Range from to) = Range (Tuple.valueOf from) (Tuple.valueOf to)

instance (NiceValue.C n) => NiceValue.C (Range n) where
   type Repr (Range n) = Range (NiceValue.Repr n)
   cons (Range from to) = zipRange (NiceValue.cons from) (NiceValue.cons to)
   undef = NiceValue.compose $ singletonRange NiceValue.undef
   zero = NiceValue.compose $ singletonRange NiceValue.zero
   phi bb a =
      case unzipRange a of
         Range a0 a1 ->
            Monad.lift2 zipRange (NiceValue.phi bb a0) (NiceValue.phi bb a1)
   addPhi bb a b =
      case (unzipRange a, unzipRange b) of
         (Range a0 a1, Range b0 b1) ->
            NiceValue.addPhi bb a0 b0 >>
            NiceValue.addPhi bb a1 b1

type instance
   NiceValue.Decomposed f (Range pn) = Range (NiceValue.Decomposed f pn)
type instance
   NiceValue.PatternTuple (Range pn) = Range (NiceValue.PatternTuple pn)

instance (NiceValue.Compose n) => NiceValue.Compose (Range n) where
   type Composed (Range n) = Range (NiceValue.Composed n)
   compose (Range from to) =
      zipRange (NiceValue.compose from) (NiceValue.compose to)

instance (NiceValue.Decompose pn) => NiceValue.Decompose (Range pn) where
   decompose (Range pfrom pto) rng =
      case unzipRange rng of
         Range from to ->
            Range
               (NiceValue.decompose pfrom from)
               (NiceValue.decompose pto to)



singletonShifted :: n -> Shifted n
singletonShifted n = Shifted n n

unzipShifted :: NiceValue.T (Shifted n) -> Shifted (NiceValue.T n)
unzipShifted (NiceValue.Cons (Shifted from to)) =
   Shifted (NiceValue.Cons from) (NiceValue.Cons to)

zipShifted :: NiceValue.T n -> NiceValue.T n -> NiceValue.T (Shifted n)
zipShifted (NiceValue.Cons from) (NiceValue.Cons to) =
   NiceValue.Cons (Shifted from to)

instance (Tuple.Undefined n) => Tuple.Undefined (Shifted n) where
   undef = Shifted Tuple.undef Tuple.undef

instance (Tuple.Value n) => Tuple.Value (Shifted n) where
   type ValueOf (Shifted n) = Shifted (Tuple.ValueOf n)
   valueOf (Shifted start len) =
      Shifted (Tuple.valueOf start) (Tuple.valueOf len)

instance (NiceValue.C n) => NiceValue.C (Shifted n) where
   type Repr (Shifted n) = Shifted (NiceValue.Repr n)
   cons (Shifted start len) =
      zipShifted (NiceValue.cons start) (NiceValue.cons len)
   undef = NiceValue.compose $ singletonShifted NiceValue.undef
   zero = NiceValue.compose $ singletonShifted NiceValue.zero
   phi bb a =
      case unzipShifted a of
         Shifted a0 a1 ->
            Monad.lift2 zipShifted
               (NiceValue.phi bb a0) (NiceValue.phi bb a1)
   addPhi bb a b =
      case (unzipShifted a, unzipShifted b) of
         (Shifted a0 a1, Shifted b0 b1) ->
            NiceValue.addPhi bb a0 b0 >>
            NiceValue.addPhi bb a1 b1

type instance
   NiceValue.Decomposed f (Shifted pn) =
      Shifted (NiceValue.Decomposed f pn)
type instance
   NiceValue.PatternTuple (Shifted pn) =
      Shifted (NiceValue.PatternTuple pn)

instance (NiceValue.Compose n) => NiceValue.Compose (Shifted n) where
   type Composed (Shifted n) = Shifted (NiceValue.Composed n)
   compose (Shifted start len) =
      zipShifted (NiceValue.compose start) (NiceValue.compose len)

instance (NiceValue.Decompose pn) => NiceValue.Decompose (Shifted pn) where
   decompose (Shifted pstart plen) rng =
      case unzipShifted rng of
         Shifted start len ->
            Shifted
               (NiceValue.decompose pstart start)
               (NiceValue.decompose plen len)



unzipCyclic :: NiceValue.T (Cyclic n) -> Cyclic (NiceValue.T n)
unzipCyclic (NiceValue.Cons (Cyclic n)) = Cyclic (NiceValue.Cons n)

cyclicSize :: (Expr.Value val) => val (Cyclic n) -> val n
cyclicSize = Expr.lift1 $ Shape.cyclicSize . unzipCyclic

cyclic :: (Expr.Value val) => val n -> val (Cyclic n)
cyclic = Expr.lift1 $ \(NiceValue.Cons n) -> NiceValue.Cons (Cyclic n)

instance (Tuple.Undefined n) => Tuple.Undefined (Cyclic n) where
   undef = Cyclic Tuple.undef

instance (Tuple.Phi n) => Tuple.Phi (Cyclic n) where
   phi bb = fmap Cyclic . Tuple.phi bb . Shape.cyclicSize
   addPhi bb (Shape.Cyclic a) (Shape.Cyclic b) = Tuple.addPhi bb a b

instance (Tuple.Value n) => Tuple.Value (Cyclic n) where
   type ValueOf (Cyclic n) = Cyclic (Tuple.ValueOf n)
   valueOf (Cyclic n) = Cyclic $ Tuple.valueOf n

instance (NiceValue.C n) => NiceValue.C (Cyclic n) where
   type Repr (Cyclic n) = Cyclic (NiceValue.Repr n)
   cons (Cyclic n) = cyclic (NiceValue.cons n)
   undef = cyclic NiceValue.undef
   zero = cyclic NiceValue.zero
   phi bb = Monad.lift cyclic . NiceValue.phi bb . cyclicSize
   addPhi bb a b = NiceValue.addPhi bb (cyclicSize a) (cyclicSize b)

type instance
   NiceValue.Decomposed f (Cyclic pn) = Cyclic (NiceValue.Decomposed f pn)
type instance
   NiceValue.PatternTuple (Cyclic pn) = Cyclic (NiceValue.PatternTuple pn)

instance (NiceValue.Compose n) => NiceValue.Compose (Cyclic n) where
   type Composed (Cyclic n) = Cyclic (NiceValue.Composed n)
   compose (Cyclic n) = cyclic (NiceValue.compose n)

instance (NiceValue.Decompose pn) => NiceValue.Decompose (Cyclic pn) where
   decompose (Cyclic p) sh = NiceValue.decompose p <$> unzipCyclic sh

instance (Expr.Compose n) => Expr.Compose (Cyclic n) where
   type Composed (Cyclic n) = Cyclic (Expr.Composed n)
   compose (Cyclic n) = Expr.lift1 cyclic (Expr.compose n)

instance (Expr.Decompose pn) => Expr.Decompose (Cyclic pn) where
   decompose (Cyclic p) = Cyclic . Expr.decompose p . cyclicSize

instance (Memory.C n) => Memory.C (Cyclic n) where
   type Struct (Cyclic n) = Memory.Struct n
   compose = Memory.compose . Shape.cyclicSize
   decompose = fmap Cyclic . Memory.decompose

instance (Marshal.C n) => Marshal.C (Cyclic n) where
   pack = Marshal.pack . Shape.cyclicSize
   unpack = Shape.Cyclic . Marshal.unpack



instance (Enum enum, Bounded enum) => NiceValue.C (Enumeration enum) where
   type Repr (Enumeration enum) = ()
   cons = NiceValue.consUnit
   undef = NiceValue.undefUnit
   zero = NiceValue.zeroUnit
   phi = NiceValue.phiUnit
   addPhi = NiceValue.addPhiUnit

type instance NiceValue.Decomposed f (Enumeration enum) = Enumeration enum
type instance NiceValue.PatternTuple (Enumeration enum) = Enumeration enum

instance
      (Enum enum, Bounded enum) => NiceValue.Compose (Enumeration enum) where
   type Composed (Enumeration enum) = Enumeration enum
   compose = NiceValue.cons

instance NiceValue.Decompose (Enumeration enum) where
   decompose Enumeration _ = Enumeration


instance (Enum enum, Bounded enum) => Expr.Compose (Enumeration enum) where
   type Composed (Enumeration enum) = Enumeration enum
   compose = Expr.cons

instance Expr.Decompose (Enumeration enum) where
   decompose Enumeration _ = Enumeration