{-# LANGUAGE FlexibleContexts
           , FlexibleInstances
           , OverlappingInstances
           , DeriveDataTypeable #-}

module Foreign.MathLink.Expressible ( Expression(..)
                                    , Expressible(..)
                                    , Dimensional(..)
                                    , ExpressibleError(..)
                                    , integralToExpression
                                    , expressionToIntegral
                                    , realFracToExpression
                                    , expressionToRealFrac
                                    , fromDimensions
                                    , arrayToExpression
                                    , expressionToArray
                                    , arrayToPair
                                    , pairToArray
                                    ) where

import Data.Int
import Data.Word
import Data.Ratio
import Data.Complex
import Data.Ix
import Data.Array.IArray
import qualified Data.Array as A
import qualified Data.Array.Unboxed as U
import Data.Typeable
import Control.Exception

import Control.Monad ( replicateM
                     )

import Data.List ( tails
                 )

import Foreign.MathLink.IO


-- | Represents a general /Mathematica/ expression.
data Expression = -- | An atomic value of integer type
                  ExInt Int
                  -- | An atomic value of floating point type
                | ExReal Double
                  -- | An atomic value of string type
                | ExString String
                  -- | An atomic value of symbol type
                | ExSymbol String
                  -- | A non-atomic value, with a head of type symbol
                  --   and a list of arguments
                | ExFunction String [Expression]
                  deriving (Eq,Ord,Read,Show)

-- | Instances of 'Expressible' are precisely the data types that can
-- be marshaled to and from /Mathematica/.
-- 
-- Minimal complete definition: 'toExpression' and 'fromExpression'.
class Expressible a where
    -- | Convert a value to an 'Expression'
    toExpression :: a -> Expression
    -- | Convert an expression to a value.
    fromExpression :: Expression -> Either ExpressibleError a
    -- | Send a value to /Mathematica/.
    put :: a -> IO ()
    put v = put $ toExpression v
    -- | Receive a value from /Mathematica/.
    get :: IO a
    get = do
      expr <- get
      case fromExpression expr of
        Left err -> throwIO err
        Right v  -> return v

maybeThrow :: Maybe MathLinkError -> IO ()
maybeThrow (Just err) = throwIO err
maybeThrow Nothing = return ()

valueOrThrow :: Either MathLinkError b -> IO b
valueOrThrow (Left err) = throwIO err
valueOrThrow (Right v) = return v

instance Expressible Expression where
    toExpression = id
    fromExpression = Right
    put expr = 
      case expr of
        ExInt i -> putInt i >>= maybeThrow
        ExReal r -> putDouble r >>= maybeThrow
        ExString s -> putString s >>= maybeThrow
        ExSymbol s -> putSymbol s >>= maybeThrow
        ExFunction hd args -> do 
          putFunction hd (length args) >>= maybeThrow
          mapM_ put args
    get = do
      typ <- getType
      case typ of
        ErrorTypeCode -> 
          getError >>= throwIO
        IntTypeCode -> 
          getInt >>= valueOrThrow >>= (return . ExInt)
        RealTypeCode -> 
          getDouble >>= valueOrThrow >>= (return . ExReal)
        StringTypeCode -> 
          getString >>= valueOrThrow >>= (return . ExString)
        SymbolTypeCode -> 
          getSymbol >>= valueOrThrow >>= (return . ExSymbol)
        FunctionTypeCode -> do
          (hd,nArgs) <- getFunction >>= valueOrThrow
          args <- replicateM nArgs get
          return $ ExFunction hd args


-- bool instance

instance Expressible Bool where
    toExpression True = ExSymbol "True"
    toExpression False = ExSymbol "False"
    fromExpression expr =
      case expr of
        ExSymbol "True"  -> Right True
        ExSymbol "False" -> Right False
        _                -> marshalErr "Bool" expr
    put True = putSymbol "True" >>= maybeThrow
    put False = putSymbol "False" >>= maybeThrow

instance Expressible Char where
    toExpression c = ExString [c]
    fromExpression expr =
      case expr of
        ExString [c] -> Right c
        _            -> marshalErr "Char" expr

integralToExpression :: Integral i => i -> Expression
integralToExpression = ExInt . fromIntegral

expressionToIntegral :: Integral i 
                     => Expression 
                     -> Either ExpressibleError i
expressionToIntegral expr =
    case expr of
      ExInt i  -> Right $ fromIntegral i
      ExReal r -> Right $ truncate r
      _        -> marshalErr "Integral" expr

putWith :: (a -> IO (Maybe MathLinkError)) -> a -> IO ()
putWith f v = f v >>= maybeThrow

getWith :: IO (Either MathLinkError a) -> IO a
getWith f = f >>= valueOrThrow

instance Expressible Int where
    toExpression = integralToExpression
    fromExpression = expressionToIntegral
    put = putWith putInt
    get = getWith getInt

instance Expressible Int8 where
    toExpression = integralToExpression
    fromExpression = expressionToIntegral
    put = putWith putInt16
    get = getWith getInt16

instance Expressible Int16 where
    toExpression = integralToExpression
    fromExpression = expressionToIntegral
    put = putWith putInt16
    get = getWith getInt16

instance Expressible Int32 where
    toExpression = integralToExpression
    fromExpression = expressionToIntegral
    put = putWith putInt32
    get = getWith getInt32

instance Expressible Int64 where
    toExpression = integralToExpression
    fromExpression = expressionToIntegral
    put = putWith putInt
    get = getWith getInt

instance Expressible Integer where
    toExpression = integralToExpression
    fromExpression = expressionToIntegral
    put = putWith putInt
    get = getWith getInt

instance Expressible Word8 where
    toExpression = integralToExpression
    fromExpression = expressionToIntegral
    put = putWith putInt16
    get = getWith getInt16

realFracToExpression :: RealFrac r => r -> Expression
realFracToExpression = ExReal . realToFrac

expressionToRealFrac :: RealFrac r 
                     => Expression 
                     -> Either ExpressibleError r
expressionToRealFrac expr =
    case expr of
      ExInt i  -> Right $ realToFrac i
      ExReal r -> Right $ realToFrac r
      _        -> marshalErr "RealFrac" expr

instance Expressible Float where
    toExpression = realFracToExpression
    fromExpression = expressionToRealFrac
    put = putWith putFloat
    get = getWith getFloat

instance Expressible Double where
    toExpression = realFracToExpression
    fromExpression = expressionToRealFrac
    put = putWith putDouble
    get = getWith getDouble

instance (Expressible i, Integral i) => Expressible (Ratio i) where
    toExpression r = ExFunction "Rational" [ toExpression $ numerator r
                                           , toExpression $ denominator r
                                           ]
    fromExpression expr =
        case expr of
          ExInt i                     -> Right $ fromIntegral i
          ExReal r                    -> Right $ realToFrac r
          ExFunction "Rational" [n,d] ->
              case (fromExpression n, fromExpression d) of
                (Right n', Right d') -> Right $ n' % d'
                (e1,e2) -> Left $ ExpressibleErrors [ e |
                  Just e <- [ getErr e1
                            , getErr e2
                            ] ]
    put r = do 
      putFunction "Rational" 2 >>= maybeThrow
      put (numerator r) >> put (denominator r)

instance (RealFloat a, Expressible a) => Expressible (Complex a) where
    toExpression (r :+ i) = ExFunction "Complex" $ map toExpression [r,i]
    fromExpression expr =
        case expr of
          ExInt i                    -> Right $ fromIntegral i
          ExReal r                   -> Right $ realToFrac r
          ExFunction "Complex" [r,i] -> 
              case (fromExpression r,fromExpression i) of
                (Right r',Right i') -> Right $ r' :+ i'
                (e1,e2) -> Left $ ExpressibleErrors [ e | 
                  Just e <- [ getErr e1
                            , getErr e2
                            ] ]
          _ -> marshalErr "Complex" expr 
    put (r :+ i) = do
      putFunction "Complex" 2 >>= maybeThrow
      put r >> put i

instance Expressible e => Expressible (Maybe e) where
  toExpression (Just e) = ExFunction "Just" [toExpression e]
  toExpression Nothing  = ExSymbol "Nothing"
  fromExpression expr =
    case expr of
      ExSymbol "Nothing"    -> Right Nothing
      ExFunction "Just" [e] -> 
        case fromExpression e of
          Left err -> Left err
          Right e  -> Right $ Just $ e
      _ -> marshalErr "Maybe" expr
  put (Just e) = do
      putFunction "Just" 1 >>= maybeThrow
      put e
  put Nothing = putSymbol "Nothing" >>= maybeThrow


instance ( Expressible e1
         , Expressible e2) 
         => Expressible (Either e1 e2) where
  toExpression (Left l)  = ExFunction "Left"  [toExpression l]
  toExpression (Right r) = ExFunction "Right" [toExpression r]
  fromExpression expr =
    case expr of
      ExFunction "Left"  [e] -> 
        case fromExpression e of
          Left err -> Left err
          Right l  -> Right $ Left $ l
      ExFunction "Right" [e] -> 
        case fromExpression e of
          Left err -> Left err
          Right r  -> Right $ Right $ r
      _ -> marshalErr "Either" expr
  put (Left v) = do
      putFunction "Left" 1 >>= maybeThrow
      put v
  put (Right v) = do
      putFunction "Right" 1 >>= maybeThrow
      put v

-- tuple instances

throwErrs :: [Maybe ExpressibleError] -> IO ()
throwErrs mErrs = throwIO $ collectErrs mErrs

throwErr :: (Show a, Show b) => a -> b -> IO c
throwErr expected got = 
  case marshalErr expected got of
    Left err -> throwIO err
    Right x -> return x

instance ( Expressible e1
         , Expressible e2
         ) => Expressible (e1,e2) where
    toExpression (ex1,ex2) = 
        ExFunction "List" $ [ toExpression ex1
                            , toExpression ex2
                            ]
    fromExpression expr =
        case expr of
          ExFunction _ [ex1,ex2] ->
            case ( fromExpression ex1
                 , fromExpression ex2
                 ) of
              (Right ex1',Right ex2') -> Right (ex1',ex2')
              (e1,e2) -> 
                Left $ collectErrs [ getErr e1
                                   , getErr e2
                                   ]
          _ -> marshalErr "(,)" expr
    put (v1,v2) = do
      putFunction "List" 2 >>= maybeThrow
      put v1 >> put v2
    get = do
      (hd,n) <- getFunction >>= valueOrThrow
      case (hd,n) of
        ("List",2) -> do v1 <- get
                         v2 <- get
                         return (v1,v2)
        pr -> throwErr ("List",2) pr

instance ( Expressible e1
         , Expressible e2
         , Expressible e3
         ) => Expressible (e1,e2,e3) where
    toExpression (ex1,ex2,ex3) = 
        ExFunction "List" $ [ toExpression ex1
                            , toExpression ex2
                            , toExpression ex3
                            ]
    fromExpression expr =
        case expr of
          ExFunction _ [ex1,ex2,ex3] ->
            case ( fromExpression ex1
                 , fromExpression ex2
                 , fromExpression ex3
                 ) of
              (Right ex1',Right ex2',Right ex3') -> 
                Right (ex1',ex2',ex3')
              (e1,e2,e3) -> 
                Left $ collectErrs [ getErr e1
                                   , getErr e2
                                   , getErr e3
                                   ]
          _ -> marshalErr "(,,)" expr
    put (v1,v2,v3) = do
      putFunction "List" 3 >>= maybeThrow
      put v1 >> put v2 >> put v3
    get = do
      (hd,n) <- getFunction >>= valueOrThrow
      case (hd,n) of
        ("List",3) -> do v1 <- get
                         v2 <- get
                         v3 <- get
                         return (v1,v2,v3)
        pr -> throwErr ("List",3) pr

instance ( Expressible e1
         , Expressible e2
         , Expressible e3
         , Expressible e4
         ) => Expressible (e1,e2,e3,e4) where
    toExpression (ex1,ex2,ex3,ex4) = 
        ExFunction "List" $ [ toExpression ex1
                            , toExpression ex2
                            , toExpression ex3
                            , toExpression ex4
                            ]
    fromExpression expr =
        case expr of
          ExFunction _ [ex1,ex2,ex3,ex4] ->
            case ( fromExpression ex1
                 , fromExpression ex2
                 , fromExpression ex3
                 , fromExpression ex4
                 ) of
              (Right ex1',Right ex2',Right ex3',Right ex4') -> 
                Right (ex1',ex2',ex3',ex4')
              (e1,e2,e3,e4) -> 
                Left $ collectErrs [ getErr e1
                                   , getErr e2
                                   , getErr e3
                                   , getErr e4
                                   ]
          _ -> marshalErr "(,,,)" expr
    put (v1,v2,v3,v4) = do
      putFunction "List" 4 >>= maybeThrow
      put v1 >> put v2 >> put v3 >> put v4
    get = do
      (hd,n) <- getFunction >>= valueOrThrow
      case (hd,n) of
        ("List",4) -> do v1 <- get
                         v2 <- get
                         v3 <- get
                         v4 <- get
                         return (v1,v2,v3,v4)
        pr -> throwErr ("List",4) pr

instance ( Expressible e1
         , Expressible e2
         , Expressible e3
         , Expressible e4
         , Expressible e5
         ) => Expressible (e1,e2,e3,e4,e5) where
    toExpression (ex1,ex2,ex3,ex4,ex5) = 
        ExFunction "List" $ [ toExpression ex1
                            , toExpression ex2
                            , toExpression ex3
                            , toExpression ex4
                            , toExpression ex5
                            ]
    fromExpression expr =
        case expr of
          ExFunction _ [ex1,ex2,ex3,ex4,ex5] ->
            case ( fromExpression ex1
                 , fromExpression ex2
                 , fromExpression ex3
                 , fromExpression ex4
                 , fromExpression ex5
                 ) of
              (Right ex1',Right ex2',Right ex3',Right ex4',Right ex5') -> 
                Right (ex1',ex2',ex3',ex4',ex5')
              (e1,e2,e3,e4,e5) -> 
                Left $ collectErrs [ getErr e1
                                   , getErr e2
                                   , getErr e3
                                   , getErr e4
                                   , getErr e5
                                   ]
          _ -> marshalErr "(,,,,)" expr
    put (v1,v2,v3,v4,v5) = do
      putFunction "List" 5 >>= maybeThrow
      put v1 >> put v2 >> put v3 >> put v4 >> put v5
    get = do
      (hd,n) <- getFunction >>= valueOrThrow
      case (hd,n) of
        ("List",5) -> do v1 <- get
                         v2 <- get
                         v3 <- get
                         v4 <- get
                         v5 <- get
                         return (v1,v2,v3,v4,v5)
        pr -> throwErr ("List",5) pr

-- list instance(s)

listToExpression :: Expressible e => [e] -> Expression
listToExpression es = ExFunction "List" $ map toExpression es

expressionToList :: 
    Expressible e => Expression -> Either ExpressibleError [e]
expressionToList expr =
  let mList = case expr of
                ExFunction _ args -> map fromExpression args
                _ -> [marshalErr "List" expr]
      vs = [ v | Right v <- mList ]
      errs = [ err | Left err <- mList ]
  in if null errs then
         Right vs
       else
         Left $ ExpressibleErrors errs

putListWith :: ([e] -> IO (Maybe MathLinkError)) -> [e] -> IO ()
putListWith fn es = fn es >>= maybeThrow

getListWith :: IO (Either MathLinkError [e]) -> IO [e]
getListWith fn = fn >>= valueOrThrow

instance Expressible e => Expressible [e] where
    toExpression = listToExpression
    fromExpression = expressionToList
    put xs = do
      putFunction "List" (length xs)
      mapM_ put xs
    get = do
      (hd,n) <- getFunction >>= valueOrThrow
      case hd of
        "List" -> replicateM n get
        _ -> throwErr "List" hd

instance Expressible [Char] where
    toExpression str = ExString str
    fromExpression expr =
      case expr of
        ExString s -> Right s
        _ -> marshalErr "String" expr
    put str = putString str >>= maybeThrow
    get = getString >>= valueOrThrow

instance Expressible [Int8] where
    toExpression = listToExpression
    fromExpression = expressionToList
    put = putListWith putInt16List
    get = getListWith getInt16List

instance Expressible [Int16] where
    toExpression = listToExpression
    fromExpression = expressionToList
    put = putListWith putInt16List
    get = getListWith getInt16List

instance Expressible [Int32] where
    toExpression = listToExpression
    fromExpression = expressionToList
    put = putListWith putInt32List
    get = getListWith getInt32List

instance Expressible [Int64] where
    toExpression = listToExpression
    fromExpression = expressionToList
    put = putListWith putIntList
    get = getListWith getIntList

instance Expressible [Int] where
    toExpression = listToExpression
    fromExpression = expressionToList
    put = putListWith putIntList
    get = getListWith getIntList

instance Expressible [Float] where
    toExpression = listToExpression
    fromExpression = expressionToList
    put = putListWith putFloatList
    get = getListWith getFloatList

instance Expressible [Double] where
    toExpression = listToExpression
    fromExpression = expressionToList
    put = putListWith putDoubleList
    get = getListWith getDoubleList

instance Expressible [Word8] where
    toExpression = listToExpression
    fromExpression = expressionToList
    put = putListWith putInt16List
    get = getListWith getInt16List


-- array marshaling

exprDimensions :: Expression -> [Int]
exprDimensions expr = 
    case expr of
      ExFunction "List" (arg:args) ->
        if all (==ad) ads then
            nArgs:ad
          else
            [nArgs]
        where ad = exprDimensions arg
              ads = map exprDimensions args
              nArgs = 1 + (length args)
      _ -> []

exprToList :: Expression -> [Expression]
exprToList (ExFunction "List" args) = args
exprToList v = [v]

flattenExprList :: [Expression] -> [Expression]
flattenExprList exprs = concat $ map exprToList exprs

expressionToPair :: Expressible e 
                 => Expression 
                 -> Either ExpressibleError ([Int],[e])
expressionToPair expr = 
  if null errs then
      Right (dims,es)
    else
      Left $ ExpressibleErrors errs
  where dims      = exprDimensions expr
        rnk       = length dims
        flattener = foldr1 (.) $ take rnk $ repeat flattenExprList
        exs       = flattener [expr]
        ees       = map fromExpression exs
        errs      = [ err | Left err <- ees ]
        es        = [ e   | Right e  <- ees ]

pairToArray :: ( Dimensional ix
               , IArray a e
               ) => [Int] -> [e] -> Either ExpressibleError (a ix e)
pairToArray dims xs =
  case fromDimensions dims of
    Left err -> Left err
    Right bnds -> Right $ listArray bnds xs
      
expressionToArray :: ( Expressible e
                     , Dimensional ix
                     , IArray a e
                     ) => Expression -> Either ExpressibleError (a ix e)
expressionToArray expr = 
  case expressionToPair expr of
    Left err -> Left err
    Right (dims,xs) -> pairToArray dims xs

partitionExprList :: Int -> Int -> [Expression] -> [[Expression]]
partitionExprList num sz exprs = partList num [] exprs
  where partList 0 lsts _     = lsts
        partList n lsts exprs = let (lst,rest) = splitAt sz exprs
                                 in partList (n-1) (lst:lsts) rest

pairToExpression :: Expressible e => ([Int],[e]) -> Expression
pairToExpression (dims,es) = mkList $ partExpr dims szs exs
  where exs = map toExpression es
        szs = map product $ tail $ tails dims
        mkList exprs = ExFunction "List" exprs
        partExpr []     _        exprs = exprs
        partExpr _      []       exprs = exprs
        partExpr (n:ns) (sz:szs) exprs = 
          let exprLsts = partitionExprList n sz exprs
          in map (mkList . (partExpr ns szs)) exprLsts

arrayToPair :: ( Dimensional ix
               , IArray a e
               ) => a ix e -> ([Int],[e])
arrayToPair ar = (dimensions $ bounds ar, elems ar)

arrayToExpression :: ( Expressible e
                     , Dimensional ix
                     , IArray a e
                     ) => a ix e -> Expression
arrayToExpression = pairToExpression . arrayToPair 

putArrayWith :: ( IArray a e
                , Dimensional ix
                ) => ([Int] -> [e] -> IO (Maybe MathLinkError))
                  -> (a ix e) -> IO ()
putArrayWith fn arr = let (dims,xs) = arrayToPair arr
                      in fn dims xs >>= maybeThrow

getArrayWith :: ( IArray a e
                , Dimensional ix
                ) => IO (Either MathLinkError ([Int],[e])) -> IO (a ix e)
getArrayWith fn = do
  (dims,xs) <- fn >>= valueOrThrow
  case pairToArray dims xs of
    Left err -> throwIO err
    Right v  -> return v

instance ( Dimensional ix
         ) => Expressible (U.UArray ix Int8) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putInt16Array
    get = getArrayWith getInt16Array

instance ( Dimensional ix
         ) => Expressible (U.UArray ix Int16) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putInt16Array
    get = getArrayWith getInt16Array

instance ( Dimensional ix
         ) => Expressible (U.UArray ix Int32) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putInt32Array
    get = getArrayWith getInt32Array

instance ( Dimensional ix
         ) => Expressible (U.UArray ix Int64) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putIntArray
    get = getArrayWith getIntArray

instance ( Dimensional ix
         ) => Expressible (U.UArray ix Int) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putIntArray
    get = getArrayWith getIntArray

instance ( Dimensional ix
         ) => Expressible (U.UArray ix Float) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putFloatArray
    get = getArrayWith getFloatArray

instance ( Dimensional ix
         ) => Expressible (U.UArray ix Double) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putDoubleArray
    get = getArrayWith getDoubleArray

instance ( Dimensional ix
         ) => Expressible (U.UArray ix Word8) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putInt16Array
    get = getArrayWith getInt16Array

instance ( Dimensional ix
         ) => Expressible (A.Array ix Int8) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putInt16Array
    get = getArrayWith getInt16Array

instance ( Dimensional ix
         ) => Expressible (A.Array ix Int16) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putInt16Array
    get = getArrayWith getInt16Array

instance ( Dimensional ix
         ) => Expressible (A.Array ix Int32) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putInt32Array
    get = getArrayWith getInt32Array

instance ( Dimensional ix
         ) => Expressible (A.Array ix Int64) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putIntArray
    get = getArrayWith getIntArray

instance ( Dimensional ix
         ) => Expressible (A.Array ix Int) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putIntArray
    get = getArrayWith getIntArray

instance ( Dimensional ix
         ) => Expressible (A.Array ix Float) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putFloatArray
    get = getArrayWith getFloatArray

instance ( Dimensional ix
         ) => Expressible (A.Array ix Double) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putDoubleArray
    get = getArrayWith getDoubleArray

instance ( Dimensional ix
         ) => Expressible (A.Array ix Word8) where
    toExpression = arrayToExpression
    fromExpression = expressionToArray
    put = putArrayWith putInt16Array
    get = getArrayWith getInt16Array

-- | Arrays to be marshaled to and from /Mathematica/ require indices
--   that are instances of 'Dimensional'.
class Ix ix => Dimensional ix where
    -- | The rank. Shouldn't examine its argument.
    rank :: ix -> Int
    -- | The dimensions.
    dimensions :: (ix,ix) -> [Int]
    -- | Default lower bound. Shouldn't examine its argument.
    lowerBound :: ix -> ix
    -- | The array upper bound implied by the list of dimensions and the
    --   given lower bound.
    --
    --   Should fail if the length of the list is not equal to the
    --   rank.
    upperBound :: ix -> [Int] -> Either ExpressibleError ix

-- | The bounds implied by the dimesions, using the default lower bound.
fromDimensions :: Dimensional ix => [Int] -> Either ExpressibleError (ix,ix)
fromDimensions dims = 
      case eU of
        Left err -> Left err
        Right u -> Right (l,u)
      where l = lowerBound undefined
            eU = upperBound l dims

dimensionalErr :: Dimensional ix 
               => ix 
               -> [Int] 
               -> Either ExpressibleError a
dimensionalErr i dims = Left $ ExpressibleErrorMsg $ "Expected " ++ 
  (show $ rank i) ++ " dimensions, but got " ++ (show $ length dims) ++ "."

instance Dimensional Int where
    rank _ = 1
    dimensions bnds = [rangeSize bnds]
    lowerBound _ = 0
    upperBound l [n] = Right (n+l-1)
    upperBound l ns  = dimensionalErr l ns

instance ( Dimensional i1
         , Dimensional i2
         ) => Dimensional (i1,i2) where
    rank (a1,a2) = rank a1 + rank a2
    dimensions ((l1,l2),(u1,u2)) = 
      dimensions (l1,u1) ++
      dimensions (l2,u2)
    lowerBound _ = 
      ( lowerBound undefined
      , lowerBound undefined
      )
    upperBound (l1,l2) ns = 
      case (u1',u2') of
        (Right u1,Right u2) -> 
          Right (u1,u2)
        (e1,e2) -> 
          Left $ collectErrs [ getErr e1
                             , getErr e2
                             ] 
      where (ns1,rest1) = splitAt (rank l1) ns
            ns2 = rest1
            u1' = upperBound l1 ns1
            u2' = upperBound l2 ns2
            
instance ( Dimensional i1
         , Dimensional i2
         , Dimensional i3
         ) => Dimensional (i1,i2,i3) where
    rank (a1,a2,a3) = rank a1 + rank a2 + rank a3
    dimensions ((l1,l2,l3),(u1,u2,u3)) = 
      dimensions (l1,u1) ++
      dimensions (l2,u2) ++
      dimensions (l3,u3)
    lowerBound _ = 
      ( lowerBound undefined
      , lowerBound undefined
      , lowerBound undefined
      )
    upperBound (l1,l2,l3) ns = 
      case (u1',u2',u3') of
        (Right u1,Right u2,Right u3) -> 
          Right (u1,u2,u3)
        (e1,e2,e3) -> 
          Left $ collectErrs [ getErr e1
                             , getErr e2
                             , getErr e3
                             ]
      where (ns1,rest1) = splitAt (rank l1) ns
            (ns2,rest2) = splitAt (rank l2) rest1
            ns3 = rest2
            u1' = upperBound l1 ns1
            u2' = upperBound l2 ns2
            u3' = upperBound l3 ns3
            
instance ( Dimensional i1
         , Dimensional i2
         , Dimensional i3
         , Dimensional i4
         ) => Dimensional (i1,i2,i3,i4) where
    rank (a1,a2,a3,a4) = rank a1 + rank a2 + rank a3 + rank a4
    dimensions ((l1,l2,l3,l4),(u1,u2,u3,u4)) = 
      dimensions (l1,u1) ++
      dimensions (l2,u2) ++
      dimensions (l3,u3) ++
      dimensions (l4,u4)
    lowerBound _ = 
      ( lowerBound undefined
      , lowerBound undefined
      , lowerBound undefined
      , lowerBound undefined
      )
    upperBound (l1,l2,l3,l4) ns = 
      case (u1',u2',u3',u4') of
        (Right u1,Right u2,Right u3,Right u4) -> 
          Right (u1,u2,u3,u4)
        (e1,e2,e3,e4) -> 
          Left $ collectErrs [ getErr e1
                             , getErr e2
                             , getErr e3
                             , getErr e4
                             ]
      where (ns1,rest1) = splitAt (rank l1) ns
            (ns2,rest2) = splitAt (rank l2) rest1
            (ns3,rest3) = splitAt (rank l3) rest2
            ns4 = rest3
            u1' = upperBound l1 ns1
            u2' = upperBound l2 ns2
            u3' = upperBound l3 ns3
            u4' = upperBound l4 ns4

instance ( Dimensional i1
         , Dimensional i2
         , Dimensional i3
         , Dimensional i4
         , Dimensional i5
         ) => Dimensional (i1,i2,i3,i4,i5) where
    rank (a1,a2,a3,a4,a5) = rank a1 + rank a2 + rank a3 + rank a4 + rank a5
    dimensions ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = 
      dimensions (l1,u1) ++
      dimensions (l2,u2) ++
      dimensions (l3,u3) ++
      dimensions (l4,u4) ++
      dimensions (l5,u5)
    lowerBound _ = 
      ( lowerBound undefined
      , lowerBound undefined
      , lowerBound undefined
      , lowerBound undefined
      , lowerBound undefined
      )
    upperBound (l1,l2,l3,l4,l5) ns = 
      case (u1',u2',u3',u4',u5') of
        (Right u1,Right u2,Right u3,Right u4,Right u5) -> 
          Right (u1,u2,u3,u4,u5)
        (e1,e2,e3,e4,e5) -> 
          Left $ collectErrs [ getErr e1
                             , getErr e2
                             , getErr e3
                             , getErr e4
                             , getErr e5
                             ]
      where (ns1,rest1) = splitAt (rank l1) ns
            (ns2,rest2) = splitAt (rank l2) rest1
            (ns3,rest3) = splitAt (rank l3) rest2
            (ns4,rest4) = splitAt (rank l4) rest3
            ns5 = rest4
            u1' = upperBound l1 ns1
            u2' = upperBound l2 ns2
            u3' = upperBound l3 ns3
            u4' = upperBound l4 ns4
            u5' = upperBound l5 ns5

getErr :: Either a b -> Maybe a
getErr (Left a) = Just a
getErr _        = Nothing

collectErrs :: [Maybe ExpressibleError] -> ExpressibleError
collectErrs mErrs = ExpressibleErrors [ e | Just e <- mErrs ]

data ExpressibleError = ExpressibleError 
                      | ExpressibleErrorMsg String
                      | ExpressibleErrors [ExpressibleError]
                        deriving (Eq,Show,Typeable)

instance Exception ExpressibleError where
    toException = SomeException
    fromException (SomeException e) = cast e

marshalErr :: (Show a, Show b) => a -> b -> Either ExpressibleError c
marshalErr expect expr = 
  Left $ ExpressibleErrorMsg $ 
    "Expected " ++ (show expect) ++ " but got: " ++ (show expr)