{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Synthesizer.LLVM.Complex (
   Complex.T(Complex.real, Complex.imag),
   (Complex.+:),
   Complex.cis,
   Complex.scale,
   constOf, unfold,
   ) where

import qualified Synthesizer.LLVM.Simple.Value as Value

import qualified LLVM.Extra.Memory as Memory
import LLVM.Extra.Class (Undefined, undefTuple, )

import qualified LLVM.Core as LLVM
import LLVM.Core (Value, ConstValue, IsConst, )
import LLVM.Util.Loop (Phi, phis, addPhis, )

import qualified Types.Data.Num      as TypeNum

import Control.Applicative (liftA2, )

import qualified Number.Complex as Complex

{-
import NumericPrelude.Numeric
import NumericPrelude.Base
-}

type Struct a = LLVM.Struct (a, (a, ()))

constOf :: IsConst a =>
   Complex.T a -> ConstValue (Struct a)
constOf x =
   LLVM.constStruct
      (LLVM.constOf $ Complex.real x,
        (LLVM.constOf $ Complex.imag x,
          ()))

unfold ::
   Value (Struct a) -> Complex.T (Value.T (Value a))
unfold x =
   Value.lift0 (LLVM.extractvalue x TypeNum.d0)
   Complex.+:
   Value.lift0 (LLVM.extractvalue x TypeNum.d1)


instance (Undefined a) => Undefined (Complex.T a) where
   undefTuple = (Complex.+:) undefTuple undefTuple

instance (Phi a) => Phi (Complex.T a) where
   phis bb v =
      liftA2 (Complex.+:)
         (phis bb (Complex.real v))
         (phis bb (Complex.imag v))
   addPhis bb x y = do
      addPhis bb (Complex.real x) (Complex.real y)
      addPhis bb (Complex.imag x) (Complex.imag y)


memory ::
   (Memory.C l) =>
   Memory.Record r (Struct (Memory.Struct l)) (Complex.T l)
memory =
   liftA2 (Complex.+:)
      (Memory.element Complex.real TypeNum.d0)
      (Memory.element Complex.imag TypeNum.d1)

instance (Memory.C l) => Memory.C (Complex.T l) where
   type Struct (Complex.T l) = Struct (Memory.Struct l)
   load = Memory.loadRecord memory
   store = Memory.storeRecord memory
   decompose = Memory.decomposeRecord memory
   compose = Memory.composeRecord memory