module Data.AdaptiveTuple.AdaptiveTuple (
AdaptiveTuple (..)
,AdaptiveTupleException (..)
,ATuple0
,ListTuple
,makeListTuple
,oObExcp
,insExcp
)
where
import Data.TypeLevel.Num
import Data.Data
import Control.Exception
import Control.Applicative
import Control.Arrow
import Control.Monad
fI :: (Integral a, Num b) => a -> b
fI = fromIntegral
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)
data AdaptiveTupleException =
ATupleIndexOutOfBounds String
| ATupleInsufficientInput
deriving (Show, Typeable)
instance Exception AdaptiveTupleException
oObExcp :: String -> a
oObExcp = throw . ATupleIndexOutOfBounds
insExcp :: a
insExcp = throw ATupleInsufficientInput
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
newtype Nat s => ListTuple s a = ListTuple {getListTuple :: [a]}
deriving (Eq, Functor, Show)
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