mathlink-1.1.0.0: src/Foreign/MathLink/Expressible.hs
{-# 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)