{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

--
-- Copyright (c) 2019, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

module Feldspar.Core.Language where

import Feldspar.Core.Reify
import Feldspar.Core.Representation as R
import Feldspar.Core.Types as T
import Feldspar.Core.Constructs (Data(..), Syntax(..), SyntacticFeld(..))
import Feldspar.Core.Middleend.FromTypeUtil (untypeType, literal)
import Feldspar.Core.NestedTuples

import Feldspar.Range
import Feldspar.Core.Collection
import Feldspar.Core.Interpretation hiding (SizeProp, sizeProp, literal)

import Control.Monad.Cont (runCont, cont)
import Data.Typeable (Typeable)
import Control.Applicative
import Control.Monad (zipWithM_)
import Data.Complex (Complex)
import Data.Int
import Data.IORef
import Data.List (genericLength)
import Data.Patch
import Data.Word
import Data.Hash (Hashable)

import qualified Data.ByteString.Char8 as B
import qualified Data.Bits as B
import Prelude.EDSL
import Prelude (Float, Double, Rational, ($), foldr)
import qualified Prelude as P

--------------------------------------------------
-- Array.hs
--------------------------------------------------

parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a]
parallel n f = sugarSym2 R.Parallel n f

sequential :: (Type a, Syntax s) =>
              Data Length -> s -> (Data Index -> s -> (Data a,s)) -> Data [a]
sequential = sugarSym3 Sequential

append :: Type a => Data [a] -> Data [a] -> Data [a]
append = sugarSym2 Append

getLength :: Type a => Data [a] -> Data Length
getLength = sugarSym1 GetLength

-- | Change the length of the vector to the supplied value. If the supplied
-- length is greater than the old length, the new elements will have undefined
-- value.
setLength :: Type a => Data Length -> Data [a] -> Data [a]
setLength = sugarSym2 SetLength

getIx :: Type a => Data [a] -> Data Index -> Data a
getIx = sugarSym2 GetIx

setIx :: Type a => Data [a] -> Data Index -> Data a -> Data [a]
setIx = sugarSym3 SetIx

type instance Elem      (Data [a]) = Data a
type instance CollIndex (Data [a]) = Data Index
type instance CollSize  (Data [a]) = Data Length

instance Type a => Indexed (Data [a])
  where
    (!) = getIx

instance Type a => Sized (Data [a])
  where
    collSize    = getLength
    setCollSize = setLength

instance (Type a, Type b) => CollMap (Data [a]) (Data [b])
  where
    collMap f arr = parallel (getLength arr) (f . getIx arr)

-- | Array patch
(|>) :: (Sized a, CollMap a a) =>
    Patch (CollSize a) (CollSize a) -> Patch (Elem a) (Elem a) -> Patch a a
(sizePatch |> elemPatch) a =
    collMap elemPatch $ setCollSize (sizePatch (collSize a)) a

--------------------------------------------------
-- Binding.hs
--------------------------------------------------

-- | Share an expression in the scope of a function
share :: (Syntax a, Syntax b) => a -> (a -> b) -> b
share = sugarSym2 Let

-- | Share the intermediate result when composing functions
(.<) :: (Syntax b, Syntax c) => (b -> c) -> (a -> b) -> a -> c
(.<) f g a = share (g a) f

infixr 9 .<

-- | Share an expression in the scope of a function
($<) :: (Syntax a, Syntax b) => (a -> b) -> a -> b
($<) = flip share

infixr 0 $<

--------------------------------------------------
-- Bits.hs
--------------------------------------------------

infixl 5 .<<.,.>>.
infixl 4 ⊕

class (Type a, B.Bits a, Integral a, Bounded a, Size a ~ Range a) => Bits a
  where
    -- * Logical operations
    (.&.)         :: Data a -> Data a -> Data a
    (.&.)         = sugarSym2 BAnd
    (.|.)         :: Data a -> Data a -> Data a
    (.|.)         = sugarSym2 BOr
    xor           :: Data a -> Data a -> Data a
    xor           = sugarSym2 BXor
    complement    :: Data a -> Data a
    complement    = sugarSym1 Complement

    -- * Bitwise operations
    bit           :: Data Index -> Data a
    bit           = sugarSym1 Bit
    setBit        :: Data a -> Data Index -> Data a
    setBit        = sugarSym2 SetBit
    clearBit      :: Data a -> Data Index -> Data a
    clearBit      = sugarSym2 ClearBit
    complementBit :: Data a -> Data Index -> Data a
    complementBit = sugarSym2 ComplementBit
    testBit       :: Data a -> Data Index -> Data Bool
    testBit       = sugarSym2 TestBit

    -- * Movement operations
    shiftLU       :: Data a -> Data Index -> Data a
    shiftLU       = sugarSym2 ShiftLU
    shiftRU       :: Data a -> Data Index -> Data a
    shiftRU       = sugarSym2 ShiftRU
    shiftL        :: Data a -> Data IntN -> Data a
    shiftL        = sugarSym2 ShiftL
    shiftR        :: Data a -> Data IntN -> Data a
    shiftR        = sugarSym2 ShiftR
    rotateLU      :: Data a -> Data Index -> Data a
    rotateLU      = sugarSym2 RotateLU
    rotateRU      :: Data a -> Data Index -> Data a
    rotateRU      = sugarSym2 RotateRU
    rotateL       :: Data a -> Data IntN -> Data a
    rotateL       = sugarSym2 RotateL
    rotateR       :: Data a -> Data IntN -> Data a
    rotateR       = sugarSym2 RotateR
    reverseBits   :: Data a -> Data a
    reverseBits   = sugarSym1 ReverseBits

    -- * Query operations
    bitScan       :: Data a -> Data Index
    bitScan       = sugarSym1 BitScan
    bitCount      :: Data a -> Data Index
    bitCount      = sugarSym1 BitCount

    bitSize       :: Data a -> Data Index
    bitSize       = value . bitSize'
    bitSize'      :: Data a -> Index
    bitSize'      = const $ P.fromIntegral $ finiteBitSize (undefined :: a)

    isSigned      :: Data a -> Data Bool
    isSigned      = value . isSigned'
    isSigned'     :: Data a -> Bool
    isSigned'     = const $ B.isSigned (undefined :: a)

finiteBitSize :: (B.FiniteBits b) => b -> Int
finiteBitSize = B.finiteBitSize

instance Bits Word8
instance Bits Word16
instance Bits Word32
instance Bits Word64
instance Bits WordN
instance Bits Int8
instance Bits Int16
instance Bits Int32
instance Bits Int64
instance Bits IntN

-- * Combinators

(⊕)    :: (Bits a) => Data a -> Data a -> Data a
(⊕)    =  xor
(.<<.) :: (Bits a) => Data a -> Data Index -> Data a
(.<<.) =  shiftLU
(.>>.) :: (Bits a) => Data a -> Data Index -> Data a
(.>>.) =  shiftRU

-- | Set all bits to one
allOnes :: Bits a => Data a
allOnes = complement 0

-- | Set the `n` lowest bits to one
oneBits :: Bits a => Data Index -> Data a
oneBits n = complement (allOnes .<<. n)

-- | Extract the `k` lowest bits
lsbs :: Bits a => Data Index -> Data a -> Data a
lsbs k i = i .&. oneBits k

--------------------------------------------------
-- Complex.hs
--------------------------------------------------

complex :: (Numeric a, P.RealFloat a) => Data a -> Data a -> Data (Complex a)
complex = sugarSym2 MkComplex

realPart :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data a
realPart = sugarSym1 RealPart

imagPart :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data a
imagPart = sugarSym1 ImagPart

conjugate :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data (Complex a)
conjugate = sugarSym1 Conjugate

mkPolar :: (Numeric a, P.RealFloat a)
    => Data a  -- ^ Amplitude
    -> Data a  -- ^ Angle
    -> Data (Complex a)
mkPolar = sugarSym2 MkPolar

cis :: (Numeric a, P.RealFloat a) => Data a -> Data (Complex a)
cis = sugarSym1 Cis

magnitude :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data a
magnitude = sugarSym1 Magnitude

phase :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data a
phase = sugarSym1 Phase

polar :: (Numeric a, P.RealFloat a) => Data (Complex a) -> (Data a, Data a)
polar c = (magnitude c, phase c)

infixl 6 +.

(+.) :: (Numeric a, P.RealFloat a) => Data a -> Data a -> Data (Complex a)
(+.) = complex

iunit :: (Numeric a, P.RealFloat a) => Data (Complex a)
iunit = 0 +. 1

--------------------------------------------------
-- Condition.hs
--------------------------------------------------

condition :: (Syntax a) => Data Bool -> a -> a -> a
condition c t f = sugarSym3 Condition c t f

-- | Condition operator. Use as follows:
-- > cond1 ? ex1 $
-- > cond2 ? ex2 $
-- > cond3 ? ex3 $
-- >   exDefault
(?) :: (Syntax a) => Data Bool -> a -> a -> a
(?) = condition

infixl 1 ?

--------------------------------------------------
-- ConditionM.hs
--------------------------------------------------

ifM :: Syntax a => Data Bool -> M a -> M a -> M a
ifM = sugarSym3 ConditionM

whenM :: Data Bool -> M () -> M ()
whenM c ma = ifM c ma (return ())

unlessM :: Data Bool -> M () -> M ()
unlessM c = ifM c (return ())

--------------------------------------------------
-- Conversion.hs
--------------------------------------------------

i2f :: (Integral a, Numeric b, P.RealFloat b) => Data a -> Data b
i2f = i2n

f2i :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
f2i = sugarSym1 F2I

i2n :: (Integral a, Numeric b) => Data a -> Data b
i2n = sugarSym1 I2N

b2i :: Integral a => Data Bool -> Data a
b2i = sugarSym1 B2I

truncate :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
truncate = f2i

round :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
round = sugarSym1 Round

ceiling :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
ceiling = sugarSym1 Ceiling

floor :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
floor = sugarSym1 Floor

--------------------------------------------------
-- Elements.hs
--------------------------------------------------

materialize :: Type a => Data Length -> Data (Elements a) -> Data [a]
materialize = sugarSym2 EMaterialize

write :: Type a => Data Index -> Data a -> Data (Elements a)
write = sugarSym2 EWrite

par :: Type a => Data (Elements a) -> Data (Elements a) -> Data (Elements a)
par = sugarSym2 EPar

parFor :: Type a => Data Length -> (Data Index -> Data (Elements a)) -> Data (Elements a)
parFor = sugarSym2 EparFor

skip :: Type a => Data (Elements a)
skip = sugarSym0 ESkip

--------------------------------------------------
-- Eq.hs
--------------------------------------------------

infix 4 ==
infix 4 /=

-- | Redefinition of the standard 'P.Eq' class for Feldspar
class (Type a) => Eq a
  where
    (==) :: Data a -> Data a -> Data Bool
    (==) = sugarSym2 Equal
    (/=) :: Data a -> Data a -> Data Bool
    (/=) = sugarSym2 NotEqual

instance Eq ()
instance Eq Bool
instance Eq Float
instance Eq Double
instance Eq Word8
instance Eq Word16
instance Eq Word32
instance Eq Word64
instance Eq WordN
instance Eq Int8
instance Eq Int16
instance Eq Int32
instance Eq Int64
instance Eq IntN

instance (Eq a, Eq b)                               => Eq (a,b)
instance (Eq a, Eq b, Eq c)                         => Eq (a,b,c)
instance (Eq a, Eq b, Eq c, Eq d)                   => Eq (a,b,c,d)
instance (Eq a, Eq b, Eq c, Eq d, Eq e)             => Eq (a,b,c,d,e)
instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)       => Eq (a,b,c,d,e,f)
instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a,b,c,d,e,f,g)

instance (Eq a, P.RealFloat a) => Eq (Complex a)

--------------------------------------------------
-- Error.hs
--------------------------------------------------

undef :: Syntax a => a
undef = sugarSym0 Undefined

-- | Assert that the condition holds or fail with message
assertMsg :: Syntax a => String -> Data Bool -> a -> a
assertMsg s = sugarSym2 (Assert s)

-- | Assert that the condition holds, the conditions string representation is used as the message
assert :: Syntax a => Data Bool -> a -> a
assert cond = assertMsg (show cond) cond

err :: Syntax a => String -> a
err msg = assertMsg msg false undef

--------------------------------------------------
-- FFI.hs
--------------------------------------------------

{- Omitted
foreignImport :: ( Type (DenResult a)
                 , SyntacticN c b
                 , ApplySym a b FeldDomain
                 )
              => String -> Denotation a -> c
foreignImport name f = sugarSymF (ForeignImport name f)
-}

--------------------------------------------------
-- Floating.hs
--------------------------------------------------

-- Make new class, with "Data" in all the types

infixr 8 **

class (Fraction a, P.Floating a) => Floating a where
  pi        :: Data a
  pi        =  sugarSym0 Pi
  exp       :: Data a -> Data a
  exp       =  sugarSym1 Exp
  sqrt      :: Data a -> Data a
  sqrt      =  sugarSym1 Sqrt
  log       :: Data a -> Data a
  log       =  sugarSym1 Log
  (**)      :: Data a -> Data a -> Data a
  (**)      =  sugarSym2 Pow
  logBase   :: Data a -> Data a -> Data a
  logBase   =  sugarSym2 LogBase
  sin       :: Data a -> Data a
  sin       =  sugarSym1 Sin
  tan       :: Data a -> Data a
  tan       =  sugarSym1 Tan
  cos       :: Data a -> Data a
  cos       =  sugarSym1 Cos
  asin      :: Data a -> Data a
  asin      =  sugarSym1 Asin
  atan      :: Data a -> Data a
  atan      =  sugarSym1 Atan
  acos      :: Data a -> Data a
  acos      =  sugarSym1 Acos
  sinh      :: Data a -> Data a
  sinh      =  sugarSym1 Sinh
  tanh      :: Data a -> Data a
  tanh      =  sugarSym1 Tanh
  cosh      :: Data a -> Data a
  cosh      =  sugarSym1 Cosh
  asinh     :: Data a -> Data a
  asinh     =  sugarSym1 Asinh
  atanh     :: Data a -> Data a
  atanh     =  sugarSym1 Atanh
  acosh     :: Data a -> Data a
  acosh     =  sugarSym1 Acosh

instance Floating Float
instance Floating Double

instance (Fraction a, P.RealFloat a) => Floating (Complex a)

π :: Floating a => Data a
π = pi
--------------------------------------------------
-- Fractional.hs
--------------------------------------------------

-- | Fractional types. The relation to the standard 'Fractional' class is
-- @instance `Fraction` a => `Fractional` (`Data` a)@
class (Fractional a, Numeric a) => Fraction a
  where
    fromRationalFrac :: Rational -> Data a
    fromRationalFrac = value . fromRational

    divFrac :: Data a -> Data a -> Data a
    divFrac = sugarSym2 DivFrac

instance Fraction Float
instance Fraction Double

instance (Fraction a, P.RealFloat a) => Fraction (Complex a)

instance (Fraction a) => Fractional (Data a)
  where
    fromRational = fromRationalFrac
    (/)          = divFrac

--------------------------------------------------
-- Future.hs
--------------------------------------------------

newtype Future a = Future { unFuture :: Data (FVal (Internal a)) }

later :: (Syntax a, Syntax b) => (a -> b) -> Future a -> Future b
later f = future . f . await

pval :: (Syntax a, Syntax b) => (a -> b) -> a -> b
pval f x = await $ force $ future (f x)

instance Syntax a => Syntactic (Future a)
  where
    type Internal (Future a) = FVal (Internal a)
    desugar = desugar . unFuture
    sugar   = Future . sugar

future :: Syntax a => a -> Future a
future = sugarSym1 MkFuture

await :: Syntax a => Future a -> a
await = sugarSym1 Await

--------------------------------------------------
-- Integral.hs
--------------------------------------------------

class (Ord a, Numeric a, BoundedInt a, P.Integral a, Size a ~ Range a) => Integral a
  where
    quot :: Data a -> Data a -> Data a
    quot = sugarSym2 Quot
    rem  :: Data a -> Data a -> Data a
    rem  = sugarSym2 Rem
    div  :: Data a -> Data a -> Data a
    div  = sugarSym2 Div
    mod  :: Data a -> Data a -> Data a
    mod  = sugarSym2 Mod
    (^)  :: Data a -> Data a -> Data a
    (^)  = sugarSym2 IExp

divSem :: Integral a
       => Data a -> Data a -> Data a
divSem x y = (x > 0 && y < 0 || x < 0 && y > 0) && rem x y /= 0 ?   quot x y P.- 1
                                                                P.$ quot x y

instance Integral Word8
instance Integral Word16
instance Integral Word32
instance Integral Word64
instance Integral WordN
instance Integral Int8
instance Integral Int16
instance Integral Int32
instance Integral Int64
instance Integral IntN

--------------------------------------------------
-- Literal.hs
--------------------------------------------------

false :: Data Bool
false = value False

true :: Data Bool
true = value True

instance Syntactic ()
  where
    type Internal () = ()
    desugar _ = ASTF (toCExpr $ toAExpr $ Literal ()) 0 -- Maybe more helpers?
    sugar _ = ()

--------------------------------------------------
-- Logic.hs
--------------------------------------------------

infixr 3 &&
infixr 3 &&*
infixr 2 ||
infixr 2 ||*

not :: Data Bool -> Data Bool
not = sugarSym1 Not

(&&) :: Data Bool -> Data Bool -> Data Bool
(&&) = sugarSym2 And

(||) :: Data Bool -> Data Bool -> Data Bool
(||) = sugarSym2 Or

-- | Lazy conjunction, second argument only evaluated if necessary
(&&*) :: Data Bool -> Data Bool -> Data Bool
a &&* b =  a ? b $ false

-- | Lazy disjunction, second argument only evaluated if necessary
(||*) :: Data Bool -> Data Bool -> Data Bool
a ||* b = a ? true $ b

--------------------------------------------------
-- Loop.hs
--------------------------------------------------

forLoop :: Syntax a => Data Length -> a -> (Data Index -> a -> a) -> a
forLoop = sugarSym3 ForLoop

whileLoop :: Syntax a => a -> (a -> Data Bool) -> (a -> a) -> a
whileLoop = sugarSym3 WhileLoop

--------------------------------------------------
-- LoopM.hs
--------------------------------------------------

forM :: (Syntax a) => Data Length -> (Data Index -> M a) -> M ()
forM = sugarSym2 For

whileM :: Syntax a => M (Data Bool) -> M a -> M ()
whileM = sugarSym2 While

--------------------------------------------------
-- MutableArray.hs
--------------------------------------------------

-- | Create a new 'Mutable' Array and intialize all elements
newArr :: Type a => Data Length -> Data a -> M (Data (MArr a))
newArr = sugarSym2 NewArr

-- | Create a new 'Mutable' Array but leave the elements un-initialized
newArr_ :: Type a => Data Length -> M (Data (MArr a))
newArr_ = sugarSym1 NewArr_

-- | Create a new 'Mutable' Array and initialize with elements from the
-- list
newListArr :: forall a. Type a => [Data a] -> M (Data (MArr a))
newListArr xs = do arr <- newArr_ (value $ genericLength xs)
                   zipWithM_ (setArr arr . value) [0..] xs
                   return arr

-- | Extract the element at index
getArr :: Type a => Data (MArr a) -> Data Index -> M (Data a)
getArr = sugarSym2 GetArr

-- | Replace the value at index
setArr :: Type a => Data (MArr a) -> Data Index -> Data a -> M ()
setArr = sugarSym3 SetArr

-- | Modify the element at index
modifyArr :: Type a
          => Data (MArr a) -> Data Index -> (Data a -> Data a) -> M ()
modifyArr arr i f = getArr arr i >>= setArr arr i . f

-- | Query the length of the array
arrLength :: Type a => Data (MArr a) -> M (Data Length)
arrLength = sugarSym1 ArrLength

-- | Modify all elements
mapArray :: Type a => (Data a -> Data a) -> Data (MArr a) -> M (Data (MArr a))
mapArray f arr = do
    len <- arrLength arr
    forArr len (flip (modifyArr arr) f)
    return arr

forArr :: Syntax a => Data Length -> (Data Index -> M a) -> M ()
forArr = sugarSym2 For

-- | Swap two elements
swap :: Type a
     => Data (MArr a) -> Data Index -> Data Index -> M ()
swap a i1 i2 = do
    tmp <- getArr a i1
    getArr a i2 >>= setArr a i1
    setArr a i2 tmp

--------------------------------------------------
-- Mutable.hs
--------------------------------------------------

newtype M a = M { unM :: Mon Mut a }
  deriving (Functor, Applicative, Monad)

instance Syntax a => Syntactic (M a)
  where
    type Internal (M a) = Mut (Internal a)
    desugar = desugar . unM
    sugar   = M . sugar

instance P.Eq (Mut a) where
 (==) = undefined

instance Show (Mut a) where
  show = undefined

runMutable :: Syntax a => M a -> a
runMutable = sugarSym1 Run

when :: Data Bool -> M () -> M ()
when = sugarSym2 When

unless :: Data Bool -> M () -> M ()
unless = when . not

instance Type a => Type (Mut a)
  where
    typeRep       = T.MutType typeRep
    sizeOf as     = undefined
    toTarget n as = undefined

--------------------------------------------------
-- MutableReference.hs
--------------------------------------------------

newtype Ref a = Ref { unRef :: Data (IORef (Internal a)) }

instance Syntax a => Syntactic (Ref a)
  where
    type Internal (Ref a) = IORef (Internal a)
    desugar = desugar . unRef
    sugar   = Ref . sugar

newRef :: Syntax a => a -> M (Ref a)
newRef = sugarSym1 NewRef

getRef :: Syntax a => Ref a -> M a
getRef = sugarSym1 GetRef

setRef :: Syntax a => Ref a -> a -> M ()
setRef = sugarSym2 SetRef

modifyRef :: Syntax a => Ref a -> (a -> a) -> M ()
modifyRef = sugarSym2 ModRef

--------------------------------------------------
-- MutableToPure.hs
--------------------------------------------------

withArray :: (Type a, Syntax b) => Data (MArr a) -> (Data [a] -> M b) -> M b
withArray = sugarSym2 WithArray

runMutableArray :: Type a => M (Data (MArr a)) -> Data [a]
runMutableArray = sugarSym1 RunMutableArray

freezeArray :: Type a => Data (MArr a) -> M (Data [a])
freezeArray marr = withArray marr return

thawArray :: Type a => Data [a] -> M (Data (MArr a))
thawArray arr = do
  marr <- newArr_ (getLength arr)
  forM (getLength arr) (\ix ->
    setArr marr ix (getIx arr ix)
   )
  return marr

--------------------------------------------------
-- Nested tuples
--------------------------------------------------

class SyntacticTup a where
    type InternalTup a
    desugarTup :: RTuple a -> ASTF (RTuple (InternalTup a))
    sugarTup   :: ASTF (RTuple (InternalTup a)) -> RTuple a

instance (Type (Internal a), Type (RTuple (InternalTup b)), Syntactic a, SyntacticTup b, Typeable (InternalTup b))
         => SyntacticTup (a :* b) where
    type InternalTup (a :* b) = Internal a :* InternalTup b
    desugarTup (x :* xs) = sugarSym2 Cons x xs
    sugarTup e = sugar (sugarSym1 Car $ Data e) :* sugarTup (sugarSym1 Cdr $ Data e)

instance SyntacticTup TNil where
    type InternalTup TNil = TNil
    desugarTup TNil = sugarSym0 Nil
    sugarTup _ = TNil

instance SyntacticTup a => Syntactic (RTuple a) where
    type Internal (RTuple a) = RTuple (InternalTup a)
    desugar t = desugarTup t
    sugar e = sugarTup e

car :: (Syntax a, SyntacticTup b, Type (RTuple (InternalTup b)), Typeable (InternalTup b))
    => RTuple (a :* b) -> a
car = sugarSym1 Car

cdr :: (Syntax a, SyntacticTup b, Type (RTuple (InternalTup b)), Typeable (InternalTup b))
    => RTuple (a :* b) -> RTuple b
cdr = sugarSym1 Cdr

instance (P.Eq (Tuple (InternalTup a)),
          Type (RTuple (InternalTup a)),
          Type (InternalTup a),
          SyntacticTup a)
      => Syntactic (Tuple a) where
    type Internal (Tuple a) = Tuple (InternalTup a)
    desugar (Tuple x) = sugarSym1 Tup x
    sugar e = Tuple $ sugar $ sugarSym1 UnTup e

--------------------------------------------------
-- NoInline.hs
--------------------------------------------------

noInline :: Syntax a => a -> a
noInline = sugarSym1 NoInline

--------------------------------------------------
-- Num.hs
--------------------------------------------------

-- There are three possibilities for making a `Num` instance for `Data`:
--   1. instance (Type a, Num a, Num (Size a)) => Num (Data a)
--   2. instance Num (Data Word8)
--      instance Num (Data Word16)
--      instance Num (Data Word32)
--      ...
--   3. The implementation in this module
-- #1 has the problem with #1 that it leaks implementation details.
-- #2 has the problem that it is verbose: The methods have to be implemented in each instance
-- (which, of course, can be taken care of using TemplateHaskell).
-- #3 avoids the above problems, but does so at the expense of having two numeric classes, which may
-- be confusing to the user.

class (Type a, Num a, Num (Size a), Hashable a) => Numeric a
  where
    fromIntegerNum :: Integer -> Data a
    fromIntegerNum =  value . fromInteger
    absNum         :: Data a -> Data a
    absNum         =  sugarSym1 Abs
    signumNum      :: Data a -> Data a
    signumNum      =  sugarSym1 Sign
    addNum         :: Data a -> Data a -> Data a
    addNum         =  sugarSym2 Add
    subNum         :: Data a -> Data a -> Data a
    subNum         =  sugarSym2 Sub
    mulNum         :: Data a -> Data a -> Data a
    mulNum         =  sugarSym2 Mul

instance Numeric Word8
instance Numeric Word16
instance Numeric Word32
instance Numeric Word64
instance Numeric WordN
instance Numeric Int8
instance Numeric Int16
instance Numeric Int32
instance Numeric Int64
instance Numeric IntN

instance Numeric Float
instance Numeric Double

instance (Type a, P.RealFloat a, Hashable a) => Numeric (Complex a)

instance (Numeric a) => Num (Data a)
  where
    fromInteger = fromIntegerNum
    abs         = absNum
    signum      = signumNum
    (+)         = addNum
    (-)         = subNum
    (*)         = mulNum

--------------------------------------------------
-- Ord.hs
--------------------------------------------------

infix 4 <
infix 4 >
infix 4 <=
infix 4 >=

-- | Redefinition of the standard 'Prelude.Ord' class for Feldspar
class (Eq a, P.Ord a, P.Ord (Size a)) => Ord a where
  (<)  :: Data a -> Data a -> Data Bool
  (<)  =  sugarSym2 LTH
  (>)  :: Data a -> Data a -> Data Bool
  (>)  =  sugarSym2 GTH

  (<=) :: Data a -> Data a -> Data Bool
  (<=) =  sugarSym2 LTE
  (>=) :: Data a -> Data a -> Data Bool
  (>=) =  sugarSym2 GTE

  min :: Data a -> Data a -> Data a
  min = sugarSym2 Min
  max :: Data a -> Data a -> Data a
  max = sugarSym2 Max

instance Ord ()
instance Ord Bool
instance Ord Word8
instance Ord Int8
instance Ord Word16
instance Ord Int16
instance Ord Word32
instance Ord Int32
instance Ord Word64
instance Ord Int64
instance Ord WordN
instance Ord IntN
instance Ord Float
instance Ord Double
--------------------------------------------------
-- Par.hs
--------------------------------------------------

newtype P a = P { unP :: Mon Par a }
  deriving (Functor, Applicative, Monad)

instance Syntax a => Syntactic (P a)
  where
    type Internal (P a) = Par (Internal a)
    desugar = desugar . unP
    sugar   = P . sugar

newtype IVar a = IVar { unIVar :: Data (IV (Internal a)) }

instance Syntax a => Syntactic (IVar a)
  where
    type Internal (IVar a) = IV (Internal a)
    desugar = desugar . unIVar
    sugar   = IVar . sugar

instance P.Eq (Par a) where
 (==) = undefined

instance Show (Par a) where
  show = undefined

instance Type a => Type (Par a)
  where
    typeRep       = T.ParType typeRep
    sizeOf as     = undefined
    toTarget n as = undefined

--------------------------------------------------
-- RealFloat.hs
--------------------------------------------------

-- Make new class, with "Data" in all the types

class (Type a, P.RealFloat a) => RealFloat a where
  atan2 :: Data a -> Data a -> Data a
  atan2 = sugarSym2 Atan2

instance RealFloat Float
instance RealFloat Double

--------------------------------------------------
-- Save.hs
--------------------------------------------------

-- | Tracing execution of Feldspar expressions

-- | An identity function that guarantees that the result will be computed as a
-- sub-result of the whole program. This is useful to prevent certain
-- optimizations.
-- Exception: Currently constant folding does not respect 'save'.
save :: Syntax a => a -> a
save = sugarSym1 Save

-- | Equivalent to 'save'. When applied to a lazy data structure, 'force' (and
-- 'save') has the effect of forcing evaluation of the whole structure.
force :: Syntax a => a -> a
force = save

--------------------------------------------------
-- SizeProp.hs
--------------------------------------------------

-- | The functions in this module can be used to help size inference (which, in
-- turn, helps deriving upper bounds of array sizes and helps optimization).

-- | An identity function affecting the abstract size information used during
-- optimization. The application of a 'SizeCap' is a /guarantee/ (by the caller)
-- that the argument is within a certain size (determined by the creator of the
-- 'SizeCap', e.g. 'sizeProp').
-- /Warning: If the guarantee is not fulfilled, optimizations become unsound!/
-- In general, the size of the resulting value is the intersection of the cap
-- size and the size obtained by ordinary size inference. That is, a 'SizeCap'
-- can only make the size more precise, not less precise.
type SizeCap a = Data a -> Data a

-- | @sizeProp prop a b@: A guarantee that @b@ is within the size @(prop sa)@,
-- where @sa@ is the size of @a@.
sizeProp :: (Syntax a, Type b) =>
    (Size (Internal a) -> Size b) -> a -> SizeCap b
sizeProp f = sugarSym2 (PropSize $ EqBox f) -- TODO

-- | A guarantee that the argument is within the given size
cap :: Type a => Size a -> SizeCap a
cap sz = sizeProp (const sz) (Data $ desugar ())

-- | @notAbove a b@: A guarantee that @b <= a@ holds
notAbove :: (Type a, Bounded a, Size a ~ Range a) => Data a -> SizeCap a
notAbove = sizeProp (Range minBound . upperBound)

-- | @notBelow a b@: A guarantee that @b >= a@ holds
notBelow :: (Type a, Bounded a, Size a ~ Range a) => Data a -> SizeCap a
notBelow = sizeProp (flip Range maxBound . lowerBound)

-- | @between l u a@: A guarantee that @l <= a <= u@ holds
between :: (Type a, Bounded a, Size a ~ Range a) =>
    Data a -> Data a -> SizeCap a
between l u = notBelow l . notAbove u

--------------------------------------------------
-- SourceInfo.hs
--------------------------------------------------
{- Omitted
-- | Source-code annotations

data SourceInfo1 a = SourceInfo1 SourceInfo

-- | Annotate an expression with information about its source code
sourceData :: Type a => SourceInfo1 a -> Data a -> Data a
sourceData info = sugarSym1 (Decor info Id)
-}

--------------------------------------------------
-- Switch.hs
--------------------------------------------------

-- | Select between the cases based on the value of the scrutinee.
-- If no match is found return the first argument
switch :: (Eq (Internal a), Hashable (Internal a), Syntax a, Syntax b)
       => b -> [(Internal a, b)] -> a -> b
switch def [] _ = def
switch def cs s = let s' = resugar s
                  in sugarSym1 Switch (foldr (\(c,a) b -> value c == s' ? a $ b) def cs)

--------------------------------------------------
-- Tuple.hs
--------------------------------------------------

instance (Syntax a, Syntax b) => Syntactic (a, b) where
  type Internal (a, b) = (Internal a, Internal b)
  sugar e = (sugar $ sugarSym1 Sel1 $ Data e,
             sugar $ sugarSym1 Sel2 $ Data e)
  desugar (x,y) = full $ op2f Tup2 @@ x @@ y

instance ( Syntax a, Syntax b, Syntax c )
      => Syntactic (a, b, c)
  where
    type Internal (a, b, c) =
                  ( Internal a, Internal b, Internal c )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              )
    desugar (a, b, c)
          = full $ op2f Tup3 @@ a @@ b @@ c

instance ( Syntax a, Syntax b, Syntax c, Syntax d )
      => Syntactic (a, b, c, d)
  where
    type Internal (a, b, c, d) =
                  ( Internal a, Internal b, Internal c, Internal d )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              )
    desugar (a, b, c, d)
          = full $ op2f Tup4 @@ a @@ b @@ c @@ d

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e
         )
      => Syntactic (a, b, c, d, e)
  where
    type Internal (a, b, c, d, e) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              )
    desugar (a, b, c, d, e)
          = full $ op2f Tup5 @@ a @@ b @@ c @@ d @@ e

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f
         )
      => Syntactic (a, b, c, d, e, f)
  where
    type Internal (a, b, c, d, e, f) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              )
    desugar (a, b, c, d, e, f)
          = full $ op2f Tup6 @@ a @@ b @@ c @@ d @@ e @@ f

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g
         )
      => Syntactic (a, b, c, d, e, f, g)
  where
    type Internal (a, b, c, d, e, f, g) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              )
    desugar (a, b, c, d, e, f, g)
          = full $ op2f Tup7 @@ a @@ b @@ c @@ d @@ e @@ f @@ g

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         )
      => Syntactic (a, b, c, d, e, f, g, h)
  where
    type Internal (a, b, c, d, e, f, g, h) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              )
    desugar (a, b, c, d, e, f, g, h)
          = full $ op2f Tup8 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i
         )
      => Syntactic (a, b, c, d, e, f, g, h, i)
  where
    type Internal (a, b, c, d, e, f, g, h, i) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i)
          = full $ op2f Tup9 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j)
          = full $ op2f Tup10 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k)
          = full $ op2f Tup11 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k, Syntax l
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k, l)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k, l) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k, Internal l
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              , sugar $ sugarSym1 Sel12 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k, l)
          = full $ op2f Tup12 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k @@ l

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k, Syntax l
         , Syntax m
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k, l, m)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k, l, m) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k, Internal l
                  , Internal m
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              , sugar $ sugarSym1 Sel12 $ Data e
              , sugar $ sugarSym1 Sel13 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k, l, m)
          = full $ op2f Tup13 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k @@ l @@ m

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k, Syntax l
         , Syntax m, Syntax n
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k, l, m, n) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k, Internal l
                  , Internal m, Internal n
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              , sugar $ sugarSym1 Sel12 $ Data e
              , sugar $ sugarSym1 Sel13 $ Data e
              , sugar $ sugarSym1 Sel14 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
          = full $ op2f Tup14 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k @@ l @@ m @@ n

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k, Syntax l
         , Syntax m, Syntax n, Syntax o
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k, Internal l
                  , Internal m, Internal n, Internal o
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              , sugar $ sugarSym1 Sel12 $ Data e
              , sugar $ sugarSym1 Sel13 $ Data e
              , sugar $ sugarSym1 Sel14 $ Data e
              , sugar $ sugarSym1 Sel15 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
          = full $ op2f Tup15 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k @@ l @@ m @@ n @@ o

-------------------------------------------------
-- Functions
-------------------------------------------------

instance (Type (Internal a), TypeF (Internal b), Syntactic a, Syntactic b) => Syntactic (a -> b) where
  type Internal (a -> b) = Internal a -> Internal b
  sugar e = undefined
  desugar f = ASTF func (i+1)
    where ASTF ce i = desugar $ f (sugar $ ASTF (toCExpr $ toAExpr $ Variable v) 0)
          (m1,e1) = catchBindings [varNum v] ce
          func = (m1, toAExpr $ Lambda v e1)
          v = Var (P.fromIntegral i + hashBase) B.empty

-------------------------------------------------
-- Converting Haskell values to Feldspar
-------------------------------------------------

value :: (Syntax a, Hashable (Internal a)) => Internal a -> a
value v = sugar $ ASTF (flattenCSE $ toCExpr $ toAExpr $ Literal v) 0

-------------------------------------------------
-- Support functions for monads
-------------------------------------------------

-- | One-layer desugaring of monadic actions
desugarMonad
    :: ( Monad m
       , Typeable m
       , Typeable a
       , Type (m a)
       , Type a
       , Size a ~ Size (m a)
       )
    => Mon m (ASTF a) -> ASTF (m a)
desugarMonad = flip runCont (sugarSym1 Return) . unMon

-- | One-layer sugaring of monadic actions
sugarMonad
    :: ( Monad m
       , Typeable m
       , Typeable a
       -- , pVar a
       , Type (m a)
       , Type a
       , Size a ~ Size (m a)
       )
    => ASTF (m a) -> Mon m (ASTF a)
sugarMonad ma = Mon $ cont $ sugarSym2 Bind ma

instance ( Syntactic a
         , Monad m
         , Typeable m
         , Typeable (Internal a)
         -- , pVar (Internal a)
         , Type (Internal a)
         , Type (m (Internal a))
         , Size (Internal a) ~ Size (m (Internal a))
         ) =>
           Syntactic (Mon m a)
  where
    type Internal (Mon m a) = m (Internal a)
    desugar = desugarMonad . fmap desugar
    sugar   = fmap sugar   . sugarMonad

-------------------------------------------------
-- Support functions
-------------------------------------------------
-- | Convert a CSE map, an Expr and an Int to an ASTF
full :: TypeF b => (CSEExpr (Expr b), Int) -> ASTF b
full (ce, i) = ASTF (flattenCSE $ transCSEExpr toAExpr ce) i

infixl 5 @@

-- Construct an application
(@@) :: (Syntactic a, TypeF (Internal a), TypeF b)
     => (CSEExpr (Expr (Internal a -> b)), Int) -> a -> (CSEExpr (Expr b), Int)
(cf,i) @@ e = go $ desugar e
  where go (ASTF ce j) = (applyCSE cf ce, P.max i j)

-- | Convenience wrappers for sugarSym
sugarSym0 :: (Syntactic a, TypeF (Internal a)) => Op (Internal a) -> a
sugarSym0 op         = unFull $ sugarSym op
sugarSym1
  :: (TypeF (Internal a), TypeF (Internal b), Syntactic a, Syntactic b)
  => Op (Internal a -> Internal b) -> a -> b
sugarSym1 op a       = unFull $ sugarSym op a
sugarSym2
  :: (TypeF (Internal a), TypeF (Internal b), TypeF (Internal c),
      Syntactic a, Syntactic b, Syntactic c) =>
     Op (Internal a -> Internal b -> Internal c) -> a -> b -> c
sugarSym2 op a b     = unFull $ sugarSym op a b
sugarSym3
  :: (TypeF (Internal a), TypeF (Internal b), TypeF (Internal c),
      TypeF (Internal d), Syntactic a, Syntactic b, Syntactic c,
      Syntactic d) =>
     Op (Internal a -> Internal b -> Internal c -> Internal d)
     -> a -> b -> c -> d
sugarSym3 op a b c   = unFull $ sugarSym op a b c
sugarSym4
  :: (TypeF (Internal a), TypeF (Internal b), TypeF (Internal c),
      TypeF (Internal d), TypeF (Internal e), Syntactic a, Syntactic b,
      Syntactic c, Syntactic d, Syntactic e) =>
     Op
       (Internal a
        -> Internal b -> Internal c -> Internal d -> Internal e)
     -> a -> b -> c -> d -> e
sugarSym4 op a b c d = unFull $ sugarSym op a b c d

-- | Convert an 'Op' to a function that builds the corresponding syntax tree
sugarSym :: SugarF a => Op (SugarT a) -> a
sugarSym = sugarF . op2f

-- | Mark an application as full rather than partial
newtype FFF a = FFF a

-- | Force the argument to be a full applicaton, resolving the
--   overloading in sugarSym
unFull :: FFF a -> a
unFull (FFF x) = x

op2f :: Op a -> (RCSExpr a, Int)
op2f op = (toCExpr $ Operator op, 0)

type RCSExpr a = CSEExpr (Expr a)

-- | Support for the overloaded sugarSym function
class SugarF a where
  type SugarT a
  sugarF :: (RCSExpr (SugarT a), Int) -> a

instance (Syntactic b, TypeF (Internal b), TypeF (SugarT c), SugarF c) => SugarF (b -> c) where
  type SugarT (b -> c) = Internal b -> SugarT c
  sugarF f = \ e -> sugarF $ f @@ e

instance (Syntactic b, TypeF (Internal b)) => SugarF (FFF b) where
  type SugarT (FFF b) = Internal b
  sugarF (ce,i) = FFF $ sugar $ ASTF (flattenCSE $ transCSEExpr toAExpr ce) i


-- |
-- Module      : Jeopardy.Controller
-- Description : MVC for our game
-- Copyright   : (c) Jonatan H Sundqvist, year
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created date year

-- TODO | -
--        -

-- SPEC | -
--        -

module Jeopardy.Controller where

---------------------------------------------------------------------------------------------------
-- We'll need these
---------------------------------------------------------------------------------------------------
import Graphics.UI.Gtk                   --
import Graphics.Rendering.Cairo (liftIO, fill) --

import Data.IORef   --
import Data.Complex --
import Data.Maybe (listToMaybe, maybe)
import Data.List (findIndex)

import Text.Printf

import qualified Southpaw.Picasso.Palette as Palette
import qualified Southpaw.Interactive.Application as App

import Jeopardy.Graphics -- TODO: Better name
import Jeopardy.Core     -- TODO: Better name
import Jeopardy.Curator  --
import Tiler             --

---------------------------------------------------------------------------------------------------
-- Types
---------------------------------------------------------------------------------------------------
-- |
-- TODO: Input state (?)
-- data App      = App { _window :: Window, _canvas :: DrawingArea, _size :: (Int, Int), _state :: IORef AppState } --
data AppState = AppState { _game :: Game, _selected :: Maybe Int, _path :: [Complex Double] }                    --

---------------------------------------------------------------------------------------------------
-- Data
---------------------------------------------------------------------------------------------------
fps = 30 :: Int

---------------------------------------------------------------------------------------------------
-- Functions
---------------------------------------------------------------------------------------------------
-- Events -----------------------------------------------------------------------------------------
-- |
-- ondelete :: IO Bool
ondelete = do
    -- TODO: Uhmmm... what?
    liftIO $ do
	    mainQuit
	    putStrLn "Goodbye!"
	    return False

-- |
onmousemotion stateref = do
	(mx, my) <- eventCoordinates
	liftIO $ do
		let cursor = mx:+my --
		let radius = 18     --
		appstate@(AppState { _path=path }) <- readIORef stateref
		writeIORef stateref $ appstate { _selected=findIndex (within radius cursor) path }
	return False
	where within r p = (< r) . realPart . abs . subtract p

-- |
ondraw appstate = do
	--
	renderGame $ _game appstate
	-- Testing an unrelated tiling function
	renderPathWithJoints Palette.chartreuse Palette.darkviolet 18 5 $ _path appstate
	assuming (_selected appstate) $ \ sel -> do
		renderCircle 22 $ _path appstate !! sel
		Palette.choose Palette.limegreen
		fill

		renderCircle 22 $ _path appstate !! opposite sel
		Palette.choose Palette.limegreen
		fill
	where assuming (Just a) f = f a
	      assuming  _       _ = return ()
	      opposite n          = (n + 3) `mod` (length $ _path appstate)

-- |
onanimate :: DrawingArea -> IORef AppState -> IO Bool
onanimate canvas stateref = do
    widgetQueueDraw canvas
    return True

---------------------------------------------------------------------------------------------------
-- |
createApp :: IO (App.App)
createApp = App.createWindowWithCanvas 650 650 $ AppState { _game=createGame,
		                                                    _selected=Nothing,
		                                                    _path=[ (200:+200)+(70:+0)*(cos θ:+sin θ) | θ <- [0, τ/6..(τ*5/6)] ] }

---------------------------------------------------------------------------------------------------
-- |
-- TODO: Rename, move (?)
mainGTK :: IO ()
mainGTK = do
	(App.App { App._window=window, App._canvas=canvas, App._size=size, App._state=stateref }) <- createApp

	timeoutAdd (onanimate canvas stateref) (1000 `div` fps) >> return ()

	-- Events
	canvas `on` draw $ (liftIO $ readIORef stateref) >>= ondraw
	canvas `on` motionNotifyEvent $ onmousemotion stateref

	-- canvas `on` buttonPressEvent   $ onbuttonpress worldref
	-- canvas `on` buttonReleaseEvent $ onbuttonreleased worldref

	-- window `on` configureEvent $ onresize window worldref
	window `on` deleteEvent	$ ondelete
	-- window `on` keyPressEvent  $ onkeypress worldref

	mainGUI


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE DefaultSignatures #-}
#endif

#if __GLASGOW_HASKELL__ >= 705
{-# LANGUAGE PolyKinds #-}
#endif

#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase #-}
#endif

#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif

module Generics.Deriving.Functor (
  -- * Generic Functor class
    GFunctor(..)

  -- * Default method
  , gmapdefault

  -- * Internal Functor class
  , GFunctor'(..)

  ) where

import           Control.Applicative (Const, ZipList)

import qualified Data.Monoid as Monoid (First, Last, Product, Sum)
import           Data.Monoid (Dual)

import           Generics.Deriving.Base

#if MIN_VERSION_base(4,4,0)
import           Data.Complex (Complex)
#endif

#if MIN_VERSION_base(4,6,0)
import           Data.Ord (Down)
#else
import           GHC.Exts (Down)
#endif

#if MIN_VERSION_base(4,7,0)
import           Data.Proxy (Proxy)
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity)
import           Data.Monoid (Alt)
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.Functor.Product as Functor (Product)
import qualified Data.Functor.Sum as Functor (Sum)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.Semigroup as Semigroup (First, Last)
import           Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)
#endif

--------------------------------------------------------------------------------
-- Generic fmap
--------------------------------------------------------------------------------

class GFunctor' f where
  gmap' :: (a -> b) -> f a -> f b

instance GFunctor' V1 where
  gmap' _ x = case x of
#if __GLASGOW_HASKELL__ >= 708
                {}
#else
                !_ -> error "Void gmap"
#endif

instance GFunctor' U1 where
  gmap' _ U1 = U1

instance GFunctor' Par1 where
  gmap' f (Par1 a) = Par1 (f a)

instance GFunctor' (K1 i c) where
  gmap' _ (K1 a) = K1 a

instance (GFunctor f) => GFunctor' (Rec1 f) where
  gmap' f (Rec1 a) = Rec1 (gmap f a)

instance (GFunctor' f) => GFunctor' (M1 i c f) where
  gmap' f (M1 a) = M1 (gmap' f a)

instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where
  gmap' f (L1 a) = L1 (gmap' f a)
  gmap' f (R1 a) = R1 (gmap' f a)

instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where
  gmap' f (a :*: b) = gmap' f a :*: gmap' f b

instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where
  gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x)

-- instance GFunctor' UAddr where
--   gmap' _ (UAddr a) = UAddr a

-- instance GFunctor' UChar where
--   gmap' _ (UChar c) = UChar c

-- instance GFunctor' UDouble where
--   gmap' _ (UDouble d) = UDouble d

-- instance GFunctor' UFloat where
--   gmap' _ (UFloat f) = UFloat f

-- instance GFunctor' UInt where
--   gmap' _ (UInt i) = UInt i

-- instance GFunctor' UWord where
--   gmap' _ (UWord w) = UWord w

class GFunctor f where
  gmap :: (a -> b) -> f a -> f b
#if __GLASGOW_HASKELL__ >= 701
  default gmap :: (Generic1 f, GFunctor' (Rep1 f))
               => (a -> b) -> f a -> f b
  gmap = gmapdefault
#endif

gmapdefault :: (Generic1 f, GFunctor' (Rep1 f))
            => (a -> b) -> f a -> f b
gmapdefault f = to1 . gmap' f . from1

-- Base types instances
instance GFunctor ((->) r) where
  gmap = fmap

instance GFunctor ((,) a) where
  gmap = gmapdefault

instance GFunctor [] where
  gmap = gmapdefault

#if MIN_VERSION_base(4,8,0)
instance GFunctor f => GFunctor (Alt f) where
  gmap = gmapdefault
#endif

#if MIN_VERSION_base(4,9,0)
instance GFunctor (Arg a) where
  gmap = gmapdefault
#endif

#if MIN_VERSION_base(4,4,0)
instance GFunctor Complex where
  gmap = gmapdefault
#endif

instance GFunctor (Const m) where
  gmap = gmapdefault

instance GFunctor Down where
  gmap = gmapdefault

instance GFunctor Dual where
  gmap = gmapdefault

instance GFunctor (Either a) where
  gmap = gmapdefault

instance GFunctor Monoid.First where
  gmap = gmapdefault

#if MIN_VERSION_base(4,9,0)
instance GFunctor (Semigroup.First) where
  gmap = gmapdefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GFunctor Identity where
  gmap = gmapdefault
#endif

instance GFunctor IO where
  gmap = fmap

instance GFunctor Monoid.Last where
  gmap = gmapdefault

#if MIN_VERSION_base(4,9,0)
instance GFunctor Semigroup.Last where
  gmap = gmapdefault

instance GFunctor Max where
  gmap = gmapdefault
#endif

instance GFunctor Maybe where
  gmap = gmapdefault

#if MIN_VERSION_base(4,9,0)
instance GFunctor Min where
  gmap = gmapdefault

instance GFunctor NonEmpty where
  gmap = gmapdefault

instance GFunctor Option where
  gmap = gmapdefault
#endif

instance GFunctor Monoid.Product where
  gmap = gmapdefault

#if MIN_VERSION_base(4,9,0)
instance (GFunctor f, GFunctor g) => GFunctor (Functor.Product f g) where
  gmap = gmapdefault
#endif

#if MIN_VERSION_base(4,7,0)
instance GFunctor Proxy where
  gmap = gmapdefault
#endif

instance GFunctor Monoid.Sum where
  gmap = gmapdefault

#if MIN_VERSION_base(4,9,0)
instance (GFunctor f, GFunctor g) => GFunctor (Functor.Sum f g) where
  gmap = gmapdefault

instance GFunctor WrappedMonoid where
  gmap = gmapdefault
#endif

instance GFunctor ZipList where
  gmap = gmapdefault


{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module LispValTest (lispValTests) where

import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.SmallCheck as SC
import Test.Tasty.QuickCheck as QC
import Test.SmallCheck.Series

import Data.Char (isAscii)
import Data.Complex (Complex(..))
import Data.List (isPrefixOf)
import Data.IORef (newIORef)
import Data.Ratio (numerator, denominator)
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as Map
import Control.Monad (liftM2, (>=>))
import Control.Monad.Trans (lift)
import System.IO (stdout)

import Val
import EvaluationMonad (unsafeEMtoIO, liftIO)
import System.IO.Unsafe (unsafePerformIO) -- be careful! for arbitrary instance
import Types (extractValue) -- these functions can probably be removed entirely.
import Primitives
import Primitives.WriteLib (writeSharedSH, ushowString)
import Types.Port (pStdout)

instance Serial IO Val where
    series = cons1 (Symbol . pack)
                \/ (series >>= lift . unsafeEMtoIO . makeMutableList)
                \/ (makeImmutableList <$> series)
                \/ cons1 Number
                \/ cons1 (IString . pack)
                \/ (series >>= lift . fmap String . newIORef . pack)
                \/ cons1 Char
                \/ cons1 Bool
                \/ cons0 Undefined
                \/ cons0 Nil
                \/ cons0 EOF
                \/ (series >>= lift . fmap Vector . V.thaw . V.fromList)
                -- \/ cons3 Primitive
                -- Primitive function types left off for now
                -- \/ cons5 Closure
                -- Env is probably difficult/impossible to give Serial instance
                -- \/ cons1 Port
                -- Handle is probably difficult/impossible to give Serial instance

instance Serial IO LispErr where
    series = cons2 NumArgs
                \/ cons2 TypeMismatch
                -- Parser ParseError left off for now
                \/ cons1 BadSpecialForm
                \/ cons2 NotFunction
                \/ cons2 (\str name -> UnboundVar str (pack name))
                \/ cons1 (EvaluateDuringInit . pack)
                \/ cons1 Default
                \/ cons0 Quit

instance Monad m => Serial m Arity where
    series = cons1 Exactly
          \/ cons1 AtLeast
          \/ cons2 Between

instance Monad m => Serial m Number where
    series = cons1 Real \/ cons1 Complex

instance Monad m => Serial m RealNumber where
    series = cons1 Bignum \/ cons1 Ratnum \/ cons1 Flonum

instance Arbitrary Val where
    arbitrary = sized lispval'
      where lispval' 0 = oneof simpleCons
            lispval' n = oneof $ simpleCons ++
                            [ do num <- choose (0, n)
                                 unsafePerformIO
                                    . unsafeEMtoIO
                                    . makeMutableList
                                  <$> vectorOf num subval
                            , do num <- choose (0, n)
                                 unsafePerformIO
                                   . fmap Vector . V.thaw . V.fromList
                                  <$> vectorOf num subval
            -- TODO: there's quite a conundrum here. I'm not _super_
            -- concerned about being able to test immutable data. After
            -- all, all the implementations should mirror the mutable versions
            -- exactly anyway. However there's always the chance that I do
            -- something really dumb.
            -- However, it's an invariant that once we start making immutable
            -- data, everything that that data contains must also be immutable.
            -- How to encode into the Arbitrary instance? Perhaps we should
            -- choose mutable/immutable with probability favoring mutable
            -- and then we need a helper that only generates immutable data.
                            ]
              where subval = lispval' $ n `div` 2
            simpleCons = [ Symbol . pack <$> arbitrary
                         , Number <$> arbitrary
                         , IString . pack <$> arbitrary
                         , Char <$> arbitrary
                         , Bool <$> arbitrary
                         ]

instance Arbitrary LispErr where
    arbitrary = oneof [ do n <- choose (0, 3)
                           NumArgs <$> arbitrary <*> vectorOf n arbitrary
                      , liftM2 TypeMismatch arbitrary arbitrary
                      , BadSpecialForm <$> arbitrary
                      , liftM2 NotFunction arbitrary arbitrary
                      , liftM2 UnboundVar arbitrary (pack <$> arbitrary)
                      , EvaluateDuringInit . pack <$> arbitrary
                      , Default <$> arbitrary
                      , return Quit
                      ]

instance Arbitrary Arity where
    arbitrary = oneof
      [ Exactly . QC.getPositive <$> arbitrary
      , AtLeast . QC.getPositive <$> arbitrary
      , mkBetween <$> arbitrary <*> arbitrary
      ]
      where
        mkBetween lo hi = Between (QC.getPositive lo) (QC.getPositive hi)

instance Arbitrary Number where
    arbitrary = oneof [Real <$> arbitrary, Complex <$> arbitrary]

instance Arbitrary RealNumber where
    arbitrary = oneof
      [ Bignum <$> arbitrary
      , Ratnum <$> arbitrary
      , Flonum <$> arbitrary
      ]

lispValTests :: TestTree
lispValTests = testGroup "Val" [unitTests, propTests]

unitTests :: TestTree
unitTests = testGroup "Unit tests"
    [ testShowPort
    , testShowPrimitives
    , testShowFunctions
    ]

propTests :: TestTree
propTests = testGroup "Property tests" [qcTests, scTests]

qcTests :: TestTree
qcTests = testGroup "(QuickCheck)"
    [ prop_TerminationErrors
    , prop_ShowVal
    ]

scTests :: TestTree
scTests = testGroup "(SmallCheck)"
    [ prop_ShowErrPrefix
    ]

-- UNIT TESTS
testShowPort :: TestTree
testShowPort = testCase "Ports show correctly" $
    (show :: Val -> String) (Port pStdout) @?= "#<port>"

testShowPrimitives :: TestTree
testShowPrimitives = testCase "Primitives show correctly" $
    mapM_
        (\(key, func) ->
            let str = case func of
                  Primitive arity _ _ -> "#<procedure "
                                           ++ symbolAsString key ++ " "
                                           ++ displayArity arity
                                           ++ ">"
                  PrimMacro {} -> "#<macro " ++ symbolAsString key ++ ">"

            in show func @?= str)
        -- Test only some of the primitives list as eventually it will be quite large
        . take 50 $ Map.toList primitives
  where
    displayArity (Exactly n) = "(" ++ simple n ++ ")"
    displayArity (Between lo hi) = "(" ++ between lo hi ++ ")"
    displayArity (AtLeast 0) = "_"
    displayArity (AtLeast n) = "(" ++ simple n ++ " . _)"

    simple 0 = ""
    simple 1 = "_"
    simple n = "_ " ++ simple (n - 1)

    between 0 0  = ""
    between 0 1  = "[_]"
    between 0 hi = "[_] " ++ between 0 (hi - 1)
    between n hi = "_ " ++ between (n-1) (hi - 1)

testShowFunctions :: TestTree
testShowFunctions = testCase "Functions show correctly" $
    do let emptyEnv = []
       show (Closure [] Nothing [] emptyEnv (Just "testFunc"))
         @?= "#<procedure testFunc ()>"
       show (Closure ["x"] Nothing [] emptyEnv (Just "testFunc"))
         @?= "#<procedure testFunc (x)>"
       show (Closure [] Nothing [] emptyEnv Nothing)
         @?= "#<procedure lambda ()>"
       show (Closure ["x"] Nothing [] emptyEnv Nothing)
         @?= "#<procedure lambda (x)>"
       show (Closure [] (Just "xs") [] emptyEnv (Just "testFunc"))
         @?= "#<procedure testFunc xs>"
       show (Closure ["x"] (Just "xs") [] emptyEnv (Just "testFunc"))
         @?= "#<procedure testFunc (x . xs)>"
       show (Closure ["x"] (Just "xs") [] emptyEnv Nothing)
         @?= "#<procedure lambda (x . xs)>"
       show (Closure ["x", "y", "z"] (Just "others") [] emptyEnv Nothing)
         @?= "#<procedure lambda (x y z . others)>"

-- PROPERTY TESTS
prop_TerminationErrors :: TestTree
prop_TerminationErrors = QC.testProperty "Only Quit is a termination error" $
    withMaxSuccess 50 $
        \input -> isTerminationError input == case input of
            Quit -> True
            _    -> False

prop_ShowVal :: TestTree
prop_ShowVal = QC.testProperty "Showing a Val produces correct string" $
    \input -> QC.ioProperty $
        (==) <$> unsafeEMtoIO (referenceShowV input) <*> writeSharedSH input
  where referenceShowV = freezeList >=> referenceShow
        -- im not sure that this is right if s has non-ascii characters
        -- TODO [r7rs]: it's explicitly wrong, but so is 'write' atm.
        referenceShow (FNotList (Symbol s)) = pure $ unpack s
        referenceShow (FNotList EOF)        = pure   "#<eof>"
        referenceShow (FNotList (Number n)) = pure $ showNumber n
        referenceShow (FNotList (IString s)) = pure $ ushowString (unpack s) ""
        referenceShow (FNotList (Char c)) = pure $ case c of
            ' '  -> "#\\space"
            '\t' -> "#\\tab"
            '\n' -> "#\\newline"
            '\r' -> "#\\carriage-return"
            _    -> "#\\" ++ [c]
        referenceShow (FNotList (Bool b)) = pure $
            if b then "#t" else "#f"
        referenceShow (FNotList (Vector v)) =
            (\es -> "#(" ++ unwords es ++ ")")
            <$> (liftIO (V.freeze v) >>= mapM referenceShowV . V.toList)

        referenceShow (FList vs) = (\es -> "(" ++ unwords es ++ ")")
            <$> mapM referenceShowV vs
        referenceShow (FDottedList vs v) =
            (\es e -> "(" ++ unwords es ++ ". " ++ e ++ ")")
            <$> mapM referenceShowV vs <*> referenceShowV v
        --    "(" ++ unwords (map show vs) ++ " . " ++ show v ++ ")"

        showNumber (Real (Bignum i)) = show i
        showNumber (Real (Ratnum r))
          | denominator r == 1 = show $ numerator r
          | otherwise = show (numerator r)
                      ++ "/"
                      ++ show (denominator r)
        showNumber (Real (Flonum f))
          | isInfinite f = sign : "inf.0"
          | isNaN f      = "+nan.0"
          | otherwise    = show f
          where sign = if f < 0 then '-' else '+'
        showNumber (Complex (r :+ i))
          | isExactZero $ Real i = showNumber (Real r)
          | isExactZero $ Real r = showNumber (Real i) ++ "i"

          -- minus sign will be given since i is negative
          | i < 0 || isNegativeZero i = showNumber (Real r)
                                      ++ showNumber (Real i)
                                      ++ "i"
          | otherwise = showNumber (Real r)
                      ++ (if isInfinite i || isNaN i then "" else "+")
                      ++ showNumber (Real i)
                      ++ "i"

prop_ShowErrPrefix :: TestTree
prop_ShowErrPrefix = SC.testProperty "Showing LispErr is prefixed with 'Error:'" $
    changeDepth (const 3) $
        \input -> "Error: " `isPrefixOf` show (input :: LispErr)


{-# LANGUAGE GADTs, StandaloneDeriving, KindSignatures, FlexibleContexts, UndecidableInstances, FlexibleInstances #-}
module Data.Mat.Data where

import Control.Monad
import Control.Monad.Trans
import Data.Complex
import Data.Functor
import Data.List
import Foreign
import Foreign.C

import Data.Mat.MemParser
import Data.Mat.Raw

-- | Representation of a MAT data type.
--
-- The first argument determines whether this is a type pattern or an
-- actual type.
--
-- The second argument is the "underlying" datatype.
--
-- The third argument is the Haskell result type.
--
-- TODO: Extend the documentation.
data MatType :: (* -> *) -> * -> * -> * where
  -- Base types
  MatDouble  :: MatType d Double Double  -- TODO: should this be CDouble?
  MatInt64   :: MatType d Int64  Int64   -- TODO: should this be CInt64?
  MatBool    :: MatType d Word8  Bool    -- TODO: should this be CUInt8?
  MatChar    :: MatType d CUChar Char

  -- Dynamic type
  MatCell    :: MatType d (Ptr CMatVar) MatData
    -- ^ Represents a single cell, i.e., a single value of arbitrary type.

  -- Compound types
  MatComplex :: MatType d a b -> MatType d (CMatComplexSplit a) (Complex b)
  MatStruct  :: d [String] -> MatType d (Ptr CMatVar) MatStruct
    -- ^ Represents a struct array with the given number of fields.
    -- TODO: The representation should contain the names of the fields.

  MatArray   :: MatType d a b -> d Int -> MatType d a [b]
    -- ^ Represents an array with the given element type and number of
    -- elements.

  -- Other
  MatUnknown :: MatioClass -> MatioType -> MatType d (Ptr CData) ()
    -- ^ Represents a value we do not know how to interpret properly as
    -- a Haskell type. We store the class and type of the value.

showMatType :: MatType Known a b -> String
showMatType MatDouble              = "Double"
showMatType MatInt64               = "Int64"
showMatType MatBool                = "Bool"
showMatType MatChar                = "Char"
showMatType MatCell                = "Cell"
showMatType (MatComplex t)         = "Complex(" ++ showMatType t ++ ")"
showMatType (MatStruct (Known fs)) = "Struct(" ++ show (intercalate ", " fs) ++ ")"
showMatType (MatArray t (Known d)) = "[" ++ showMatType t ++ "]_" ++ show d
showMatType (MatUnknown c t)       = "Unknown(Class " ++ show c ++ ", Type " ++ show t ++ ")"

-- | Contains a dictionary for the 'Show' class.
data ShowDict a where
  ShowDict :: (Show a) => ShowDict a

-- | For a given MAT type description, compute a corresponding 'Show'
-- dictionary.
matShowDict :: MatType d a b -> ShowDict b
matShowDict MatDouble        = ShowDict
matShowDict MatInt64         = ShowDict
matShowDict MatBool          = ShowDict
matShowDict MatChar          = ShowDict
matShowDict MatCell          = ShowDict
matShowDict (MatComplex t)   = case matShowDict t of
  ShowDict -> ShowDict
matShowDict (MatStruct _)    = ShowDict
matShowDict (MatArray t _)   = case matShowDict t of
  ShowDict -> ShowDict
matShowDict (MatUnknown _ _) = ShowDict

-- | This type can be used in 'MatType' in order to represent known
-- dimensions.
newtype Known a = Known a
  deriving (Show)

-- | This type can be used in 'MatType' in order to represent unknown
-- dimensions.
data Unknown a = Unknown
  deriving (Show)

-- deriving instance (Show (d Int), Show (d [String])) => Show (MatType d a b)
-- deriving instance Eq   d => Eq   (MatType d a b)
-- deriving instance Ord  d => Ord  (MatType d a b)
instance Show (MatType Known a b) where
  show t = showMatType t

-- | Type synonym for a struct.
type MatStruct = [MatData]
  -- TODO: would [(String, MatData)] or Map String MatData be better?
  -- The type already contains the field names, but perhaps a little
  -- redundancy is ok and pragmatic here?

-- | An arbitrary 'MatType' in a wrapper.
data AnyMatType :: * where
  AnyMatType :: (Storable a) => MatType Known a b -> AnyMatType

deriving instance Show (AnyMatType)
-- deriving instance Eq   (AnyMatType)
-- deriving instance Ord  (AnyMatType)

-- | Some piece of data paired with a type annotation.
data MatData :: * where
  MatData :: MatType Known a b -> b -> MatData

-- deriving instance Show (MatData)
instance Show MatData where
  show (MatData t d) = case matShowDict t of
    ShowDict -> show d ++ " :: " ++ show t

-- TODO: Think about a proper 'Show' instance.

-- | Given a type representation, 'matParser' computes a memory parser
-- for that type.
matParser :: MatType Known a b -> MemParser a b
matParser MatDouble              = storable
matParser MatInt64               = storable
matParser MatBool                = toBool <$> storable
matParser MatChar                = castCUCharToChar <$> storable
matParser (MatComplex t)         = complex (matParser t)
matParser (MatStruct (Known d))  = do
  ptrs <- array (length d) storable
  liftIO $ forM ptrs $ matDataPtr
matParser MatCell                = do
  ptr <- storable
  liftIO (matDataPtr ptr)
matParser (MatArray t (Known n)) = array n (matParser t)
matParser (MatUnknown _ _)       = nothing

-- | Given the raw variable data structure, get the name
-- of the variable.
matVarName :: CMatVar -> IO (Maybe String)
matVarName v = maybePeek peekCString (name v)

-- | Given the raw variable data structure, get the dimensions
-- of the variable.
--
-- TODO: Can the dimensions pointer be null?
matVarDims :: CMatVar -> IO [Int]
matVarDims v = map fromIntegral <$> peekArray (fromIntegral $ rank v) (dims v)

-- | Compute the type of the represented data.
matType :: Ptr CMatVar -> CMatVar -> IO AnyMatType
matType ptr v = do
  base <- matBaseType
  ds   <- matVarDims v
  return (matComplex (matDims ds base))
  where
    matBaseType :: IO AnyMatType
    matBaseType
      | dataType v == tdouble = return $ AnyMatType MatDouble
      | dataType v == tint64  = return $ AnyMatType MatInt64
      | dataType v == tuint8 && classType v == cchar = return $ AnyMatType MatChar
      | dataType v == tuint8 && isLogical v          = return $ AnyMatType MatBool
      | dataType v == tstruct = do
          nrfields <- cMatVarGetNumberOfFields ptr
          fields   <- cMatVarGetStructFieldnames >=> peekArray (fromIntegral nrfields) >=> mapM peekCString $ ptr
          return $ AnyMatType (MatStruct (Known fields))
      | dataType v == tcell   = return $ AnyMatType MatCell
      | otherwise             = return $ AnyMatType $ MatUnknown (classType v) (dataType v)

    matDims :: [Int] -> AnyMatType -> AnyMatType
    matDims []       t = t
    matDims (d : ds) t =
      case matDims ds t of
        AnyMatType r -> AnyMatType (MatArray r (Known (fromIntegral d)))

    matComplex :: AnyMatType -> AnyMatType
    matComplex t | isComplex v =
      case t of
        AnyMatType r -> AnyMatType (MatComplex r)
                 | otherwise   = t

matTypePtr :: Ptr CMatVar -> IO AnyMatType
matTypePtr ptr = peek ptr >>= matType ptr

-- | Given a pointer to a MAT variable, provide the data in a suitable
-- Haskell structure, wrapped up with a type representation.
matData :: Ptr CMatVar -> CMatVar -> IO MatData
matData ptr v = do
  AnyMatType t <- matType ptr v
  let mp = matParser t
  x <- runMemParser mp (castPtr (theData v))
  return (MatData t x)

matDataPtr :: Ptr CMatVar -> IO MatData
matDataPtr ptr = peek ptr >>= matData ptr

data Equal :: * -> * -> * where
  Refl :: Equal a a

matTypeEqual :: MatType d a b -> MatType d' a' c -> Maybe (Equal b c)
matTypeEqual MatDouble  MatDouble = return Refl
matTypeEqual MatInt64   MatInt64  = return Refl
matTypeEqual MatBool    MatBool   = return Refl
matTypeEqual MatChar    MatChar   = return Refl
matTypeEqual MatCell    MatCell   = return Refl
matTypeEqual (MatComplex s) (MatComplex t) = do
  Refl <- matTypeEqual s t
  return Refl
matTypeEqual (MatStruct _) (MatStruct _) = return Refl
matTypeEqual (MatArray s _) (MatArray t _) = do
  Refl <- matTypeEqual s t
  return Refl
matTypeEqual _ _ = Nothing

-- | Given a value of unknown type and a type representation,
-- attempt a cast.
matCast :: MatData -> MatType d a b -> Maybe b
matCast (MatData s x) t =
  case matTypeEqual s t of
    Just Refl -> Just x
    Nothing   -> Nothing

dim2 :: MatType Unknown a b -> MatType Unknown a [[b]]
dim2 t = MatArray (MatArray t Unknown) Unknown


{-# LANGUAGE FlexibleInstances, RankNTypes #-}
module Dna.Nucleotides (
    Nucleotide, Dna, DnaList, Rna, (+:+),
    isDnaPrefixOf, lengthDna,
    groupDna, tailDna, readsDna, nullDna,
    liftDna2, liftDna, takeDna, dnaToRna,
    dropDna, dnaComplement, FastaSequence,
    parseFastaFile, highestGC)
where

import           Text.Printf
import           Data.Ratio
import           Control.Monad.IO.Class
import           Data.List
import           Data.Functor
import           Data.STRef
import           Control.Monad
import           Control.Applicative
import           Numeric.LinearAlgebra
import           Numeric.LinearAlgebra.Data
import           Numeric.LinearAlgebra.Devel
import           Control.Monad.ST
import qualified Text.Parser.Combinators as P
import qualified Text.Parser.Char as P
import qualified Text.Parser.Token as P
import qualified Text.Trifecta.Parser as P

import qualified Data.ByteString.Lazy.Char8 as C
import qualified Data.Set as S

data Nucleotide = A | C | G | T | U
    deriving (Eq, Ord)

instance Show Nucleotide where
    show A = "A"
    show C = "C"
    show G = "G"
    show T = "T"
    show U = "U"

data FastaSequence a = Fasta {
    _fastaId :: String,
    _fastaInfo :: a}

class FastaParseInfo a where
    parse :: P.TokenParsing m => m a

instance Functor FastaSequence where
    fmap f (Fasta ident datum) = Fasta ident (f datum)

instance FastaParseInfo Dna where
    parse = DnaIntern . concat <$> P.sepEndBy (many parseDnaNucleotide) P.newline

instance FastaParseInfo Rna where
    parse = RnaIntern . concat <$> P.sepEndBy (many parseRnaNucleotide) P.newline

newtype Dna = DnaIntern [Nucleotide]
    deriving (Ord, Eq)
newtype Rna = RnaIntern [Nucleotide]
    deriving (Ord, Eq)
type DnaList = [Dna]

parseFastaFile :: (FastaParseInfo a, MonadIO m) => String -> m (Maybe [FastaSequence a])
parseFastaFile = P.parseFromFile parseFastaList

parseDnaNucleotide :: P.TokenParsing m => m Nucleotide
parseDnaNucleotide = P.choice [P.string "A" *> pure A, P.string "T" *> pure T, P.string "G" *> pure G, P.string "C" *> pure C]

parseRnaNucleotide :: P.TokenParsing m => m Nucleotide
parseRnaNucleotide = P.choice [P.string "A" *> pure A, P.string "U" *> pure U, P.string "G" *> pure G, P.string "C" *> pure C]

parseFastaList :: (FastaParseInfo a, P.TokenParsing m) => m [FastaSequence a]
parseFastaList = P.many parseFasta

parseFasta :: (FastaParseInfo a, P.TokenParsing m) => m (FastaSequence a)
parseFasta = Fasta
                <$> (P.string ">" *> P.manyTill P.anyChar P.newline)
                <*> parse

unDna (DnaIntern dna) = dna
unRna (DnaIntern rna) = rna

liftDna :: ([Nucleotide] -> [Nucleotide]) -> Dna -> Dna
liftDna f (DnaIntern dna) = DnaIntern (f dna)

liftDna2 :: ([Nucleotide] -> [Nucleotide] -> a) -> Dna -> Dna -> a
liftDna2 f (DnaIntern dna1) (DnaIntern dna2) =  f dna1 dna2

groupDna :: Dna -> DnaList
groupDna = map DnaIntern . group . unDna

dropDna :: Int -> Dna -> Dna
dropDna n = liftDna $ drop n

takeDna :: Int -> Dna -> Dna
takeDna n = liftDna $ take n

tailDna :: Dna -> Dna
tailDna = liftDna tail

lengthDna :: Dna -> Int
lengthDna (DnaIntern dna) = length dna

isDnaPrefixOf :: Dna -> Dna -> Bool
isDnaPrefixOf  = liftDna2 isPrefixOf

(+:+) :: Dna -> Dna -> Dna
l +:+ r = DnaIntern $ liftDna2 (++) l r

nullDna :: Dna
nullDna = DnaIntern []

instance Show Dna where
    show (DnaIntern dna) = foldr ((++) . show) "" dna

instance Show Rna where
    show (RnaIntern rna) = foldr ((++) . show) "" rna

instance (Show a) => Show (FastaSequence a) where
    show (Fasta ident datum) = ">" ++ ident ++ "\n" ++ show datum ++ "\n"

instance {-# OVERLAPPING #-} Show (FastaSequence Rational) where
    show (Fasta ident datum) = ">" ++ ident ++ "\n" ++ show (fromRational datum :: Double)  ++ "\n"

instance {-# OVERLAPPING #-} Show DnaList where
    show = intercalate "\n" . map show

readsNucleotide          :: Int -> ReadS Nucleotide
readsNucleotide _ ('A':xs) = [(A,xs)]
readsNucleotide _ ('C':xs) = [(C,xs)]
readsNucleotide _ ('G':xs) = [(G,xs)]
readsNucleotide _ ('T':xs) = [(T,xs)]
readsNucleotide _ ('U':xs) = [(U,xs)]

instance Read Nucleotide where
    readsPrec = readsNucleotide

highestGC :: [FastaSequence Dna] -> FastaSequence Rational
highestGC = last . sortOn  _fastaInfo . fmap  ((`frequency` [C,G]) <$>)

readsDna        :: Int -> ReadS Dna
readsDna  _ []  = [(DnaIntern [],[])]
readsDna  d s@(x:xs)
    | x `elem` ['A','C','G','T'] = [(DnaIntern $ read [x]:dna, rest) | (DnaIntern dna,rest) <- readsDna (d+1) xs ]
    | otherwise = [(DnaIntern [],s)]

readsRna        :: Int -> ReadS Rna
readsRna  _ []  = [(RnaIntern [],[])]
readsRna  d s@(x:xs)
    | x `elem` ['A','C','G','U'] = [(RnaIntern $ read [x]:rna, rest) | (RnaIntern rna,rest) <- readsRna (d+1) xs ]
    | otherwise = [(RnaIntern [],s)]

readsDnaList    :: Int -> ReadS DnaList
readsDnaList _ [] = [([],[])]
readsDnaList d ('\n':xs) = readsDnaList (d+1) xs
readsDnaList d s@(x:xs)
    | x `notElem` ['A','C','G','T'] = [([],s)]
    | otherwise = [(DnaIntern dna:restDna,rest) |
            (DnaIntern dna,restRead) <- readsDna d s,
            (restDna,rest) <- readsDnaList (d+length dna) restRead]

mapComplementDan A = T
mapComplementDan T = A
mapComplementDan C = G
mapComplementDan G = C

dnaComplement :: Dna -> Dna
dnaComplement = liftDna $ reverse . map mapComplementDan

instance Read Dna where
    readsPrec = readsDna

instance Read Rna where
    readsPrec = readsRna

instance {-# OVERLAPPING #-} Read DnaList where
    readsPrec = readsDnaList

isConnected :: Dna -> Dna -> Bool
isConnected (DnaIntern first) (DnaIntern second) = and $ zipWith (==) (tail first) second

dnaToRna :: Dna -> Rna
dnaToRna = RnaIntern . map mapNucleotidDnaRna . unDna
    where mapNucleotidDnaRna T = U
          mapNucleotidDnaRna a = a

frequency :: Dna -> [Nucleotide] -> Rational
frequency (DnaIntern d) pop = fromIntegral (length (filter (`elem` pop) d)) %  fromIntegral (length d)


--
-- Copyright (c) 2009-2011, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Feldspar.Compiler.Imperative.FromCore.Literal
  (literal)
  where

import Data.Complex

import Language.Syntactic

import Feldspar.Core.Types as Core
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Literal

import Feldspar.Compiler.Imperative.Frontend
import Feldspar.Compiler.Imperative.Representation (Expression(..),Constant(..))
import qualified Feldspar.Compiler.Imperative.Representation as Rep (Type(..),
                                                                     Signedness(..),
                                                                     Size(..))
import Feldspar.Compiler.Imperative.FromCore.Interpretation

instance Compile (Literal :|| Core.Type) dom
  where
    compileExprSym (C' (Literal a)) info Nil = literal (infoType info) (infoSize info) a

    compileProgSym (C' (Literal a)) info loc Nil = case loc of
        Just l  -> literalLoc l (infoType info) (infoSize info) a
        Nothing -> return ()

literal :: TypeRep a -> Size a -> a -> CodeWriter (Expression ())
literal t@UnitType        sz a = return (ConstExpr $ literalConst t sz a)
literal t@BoolType        sz a = return (ConstExpr $ literalConst t sz a)
literal t@IntType{}       sz a = return (ConstExpr $ literalConst t sz a)
literal t@FloatType       sz a = return (ConstExpr $ literalConst t sz a)
literal t@DoubleType      sz a = return (ConstExpr $ literalConst t sz a)
literal t@ComplexType{}   sz a = return (ConstExpr $ literalConst t sz a)
literal t@ArrayType{}     sz a = return (ConstExpr $ literalConst t sz a)
literal t s a = do loc <- freshVar "x" t s
                   literalLoc loc t s a
                   return loc

literalConst :: TypeRep a -> Size a -> a -> Constant ()
literalConst UnitType        _  ()     = IntConst 0 (Rep.NumType Rep.Unsigned Rep.S32)
literalConst BoolType        _  a      = BoolConst a
literalConst trep@IntType{}  sz a      = IntConst (toInteger a) (compileTypeRep trep sz)
literalConst FloatType       _  a      = FloatConst a
literalConst DoubleType      _  a      = DoubleConst a
literalConst (ArrayType t)   _  a      = ArrayConst $ map (literalConst t (defaultSize t)) a
literalConst (ComplexType t) _  (r:+i) = ComplexConst re ie
  where re = literalConst t (defaultSize t) r
        ie = literalConst t (defaultSize t) i

literalLoc :: Expression () -> TypeRep a -> Size a -> a -> CodeWriter ()
literalLoc loc arr@ArrayType{} sz e
    = tellProg [copyProg (Just loc) [ConstExpr $ literalConst arr sz e]]

literalLoc loc (Tup2Type ta tb) (sa,sb) (a,b) =
    do literalLoc (StructField loc "member1") ta sa a
       literalLoc (StructField loc "member2") tb sb b

literalLoc loc (Tup3Type ta tb tc) (sa,sb,sc) (a,b,c) =
    do literalLoc (StructField loc "member1") ta sa a
       literalLoc (StructField loc "member2") tb sb b
       literalLoc (StructField loc "member3") tc sc c

literalLoc loc (Tup4Type ta tb tc td) (sa,sb,sc,sd) (a,b,c,d) =
    do literalLoc (StructField loc "member1") ta sa a
       literalLoc (StructField loc "member2") tb sb b
       literalLoc (StructField loc "member3") tc sc c
       literalLoc (StructField loc "member4") td sd d

literalLoc loc (Tup5Type ta tb tc td te) (sa,sb,sc,sd,se) (a,b,c,d,e) =
    do literalLoc (StructField loc "member1") ta sa a
       literalLoc (StructField loc "member2") tb sb b
       literalLoc (StructField loc "member3") tc sc c
       literalLoc (StructField loc "member4") td sd d
       literalLoc (StructField loc "member5") te se e

literalLoc loc (Tup6Type ta tb tc td te tf) (sa,sb,sc,sd,se,sf) (a,b,c,d,e,f) =
    do literalLoc (StructField loc "member1") ta sa a
       literalLoc (StructField loc "member2") tb sb b
       literalLoc (StructField loc "member3") tc sc c
       literalLoc (StructField loc "member4") td sd d
       literalLoc (StructField loc "member5") te se e
       literalLoc (StructField loc "member6") tf sf f

literalLoc loc (Tup7Type ta tb tc td te tf tg) (sa,sb,sc,sd,se,sf,sg) (a,b,c,d,e,f,g) =
    do literalLoc (StructField loc "member1") ta sa a
       literalLoc (StructField loc "member2") tb sb b
       literalLoc (StructField loc "member3") tc sc c
       literalLoc (StructField loc "member4") td sd d
       literalLoc (StructField loc "member5") te se e
       literalLoc (StructField loc "member6") tf sf f
       literalLoc (StructField loc "member7") tg sg g

literalLoc loc t sz a =
    do rhs <- literal t sz a
       assign (Just loc) rhs