{-# LANGUAGE
      MultiParamTypeClasses
     ,FlexibleInstances
     ,ScopedTypeVariables
     ,GeneralizedNewtypeDeriving
     ,DeriveDataTypeable #-}

module Data.AdaptiveTuple.AdaptiveTuple (
  -- *Type classes
  AdaptiveTuple (..)
  -- *Types
  ,AdaptiveTupleException (..)
  ,ATuple0
  ,ListTuple
  -- *Functions
  ,makeListTuple
  -- **Error functions
  ,oObExcp
  ,insExcp
  )

where

import Data.TypeLevel.Num
import Data.Data
import Control.Exception
import Control.Applicative
import Control.Arrow
import Control.Monad

-- helper function
fI :: (Integral a, Num b) => a -> b
fI = fromIntegral

-- |Adaptive tuples: unboxed tuples of varying size.
-- @s@ is a type-level indicator of the number of elements in the container.
class (Nat s, Applicative (c s)) => AdaptiveTuple c s where
  getIndex   :: c s el -> Int -> el
  setIndex   :: Int -> el -> c s el -> c s el
  mapIndex   :: (el -> el) -> Int -> c s el -> c s el
  toATuple   :: [el] -> c s el
  fromATuple :: c s el -> [el]
  tupLength  :: c s el -> Int
  tupLength _ = toInt (undefined :: s)
  sequenceAT :: (Monad m) => c s (m el) -> m (c s el)

-- -------------------------------------
-- exceptions

data AdaptiveTupleException =
    ATupleIndexOutOfBounds String
  | ATupleInsufficientInput
  deriving (Show, Typeable)

instance Exception AdaptiveTupleException

oObExcp :: String -> a
oObExcp = throw . ATupleIndexOutOfBounds

insExcp :: a
insExcp = throw ATupleInsufficientInput

-- -------------------------------------
-- basic adaptive tuple types

-- |no-element tuple
data ATuple0 s el = ATuple0 deriving (Eq, Show)

instance Functor (ATuple0 D0) where
  fmap _ _ = ATuple0

instance Applicative (ATuple0 D0) where
  pure _  = ATuple0
  _ <*> _ = ATuple0

instance AdaptiveTuple ATuple0 D0 where
  getIndex _ _   = oObExcp "getIndex"
  setIndex _ _ _ = ATuple0
  mapIndex _ _ _ = ATuple0
  toATuple _     = ATuple0
  fromATuple _   = []
  sequenceAT _   = return ATuple0

-- |A ListTuple is a List with a type-level length.
-- to be used when there isn't a more specific adaptive tuple defined
newtype Nat s => ListTuple s a = ListTuple {getListTuple :: [a]}
  deriving (Eq, Functor, Show)

-- |Create a ListTuple
makeListTuple :: Nat s => s -> [a] -> ListTuple s a
makeListTuple s xs | toInt s Prelude.< length xs =
  error $ "input list to short to make ListTuple of length " ++
          (show $ toInt s)
makeListTuple s xs = ListTuple . take (toInt s) $ xs

instance Nat s => Applicative (ListTuple s) where
  pure    = pureLT
  a <*> b = ListTuple $ zipWith ($) (getListTuple a) (getListTuple b)

pureLT :: forall s a. (Nat s) => a -> ListTuple s a
pureLT = ListTuple . replicate (toInt (undefined :: s))

instance forall s. (Nat s) => AdaptiveTuple ListTuple s where
  getIndex z i = getListTuple z !! (fI i)
  setIndex i el = ListTuple . uncurry (++) . ((++ [el]) *** drop 1) .
                        splitAt (fI i) . getListTuple
  mapIndex f i  = ListTuple . uncurry (++) . second (\(x:xs) -> f x : xs) .
                        splitAt (fI i) . getListTuple
  toATuple      = makeListTuple (undefined :: s)
  fromATuple    = getListTuple
  sequenceAT    = liftM ListTuple . sequence . getListTuple