{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
module Primitives (
    primitiveBindings
  ) where
import LispVals
import LispEnvironment
import Parse
import Eval

import Control.Monad.Trans (liftIO, MonadIO)
import Control.Monad (liftM, foldM, zipWithM)
import Control.Monad.Error (throwError, catchError, MonadError)
import Control.Monad.Cont (MonadCont, callCC)
import Data.Ratio (Ratio, (%))
import Data.Complex (Complex((:+)))
import Data.Char (toLower)
import System.IO (IOMode(ReadMode, WriteMode), hPrint, hClose, openFile, stdin, stdout)
import Data.Function (on)

primitiveBindings :: Frame
primitiveBindings = frameFromList (
        map (makeF IOFunc) ioPrimitives ++
        map (makeF PrimitiveFunc) primitives ++
        map (makeF SpecialFormFunc) specialFormPrimitives)
    where makeF constructor (var, func) = (var, constructor func)

specialFormPrimitives :: [(String, [LispVal] -> LispEval)]
specialFormPrimitives = [("if", ifProc),
                         ("case", caseProc),
                         ("cond", condProc),
                         ("set!", setProc),
                         ("string-set!", stringSetProc),
                         ("string-fill!", stringFillProc),
                         ("define", defineProc),
                         ("call-with-current-continuation", callCCProc),
                         ("lambda", lambdaProc),
                         ("load", loadProc),
                         ("apply", applyProc)]

ioPrimitives :: (MonadError LispError m, MonadIO m) => [(String, [LispVal] -> m LispVal)]
ioPrimitives = [("open-input-file", makePort ReadMode),
                ("open-output-file", makePort WriteMode),
                ("close-input-port", closePort),
                ("close-output-port", closePort),
                ("read", readProc),
                ("write", writeProc),
                ("read-contents", readContents),
                ("read-all", readAll)]

primitives :: (MonadError LispError m) => [(String, [LispVal] -> m LispVal)]
primitives = [("+", anyNumListOp (+)),
              ("-", anyNumListMinus),
              ("*", anyNumListOp (*)),
              ("/", anyNumListDiv),
              ("mod", onlyNumListOp mod),
              ("quotient", onlyNumListOp quot),
              ("remainder", onlyNumListOp rem),
              ("=", anyEqBoolListOp (==)),
              ("<", anyOrdBoolListOp (<)),
              (">", anyOrdBoolListOp (>)),
              ("/=", anyEqBoolListOp (/=)),
              (">=", anyOrdBoolListOp (>=)),
              ("<=", anyOrdBoolListOp (<=)),
              ("&&", boolBoolBinop (&&)),
              ("||", boolBoolBinop (||)),
              ("string=?", strBoolBinop (==)),
              ("string-ci=?", strBoolBinop (on (==) (map toLower))),
              ("string<=?", strBoolBinop (<=)),
              ("string-ci<=?", strBoolBinop (on (<=) (map toLower))),
              ("string>=?", strBoolBinop (>=)),
              ("string-ci>=?", strBoolBinop (on (>=) (map toLower))),
              ("string<?", strBoolBinop (<)),
              ("string-ci<?", strBoolBinop (on (<) (map toLower))),
              ("string>?", strBoolBinop (>)),
              ("string-ci>?", strBoolBinop (on (>) (map toLower))),
              ("car", car),
              ("cdr", cdr),
              ("cons", cons),
              ("eq?", eqv),
              ("eqv?", eqv),
              ("equal?", equal),
              ("string?", isLispValTest isLispValString),
              ("exact?", isLispValTest isLispValExact),
              ("inexact?", isLispValTest (not . isLispValExact)),
              ("boolean?", isLispValTest isLispValBool),
              ("number?", isLispValTest isLispValNum),
              ("complex?", isLispValTest isLispValComplex),
              ("real?", isLispValTest isLispValReal),
              ("rational?", isLispValTest isLispValRational),
              ("integer?", isLispValTest isLispValInteger),
              ("vector?", isLispValTest isLispValVector),
              ("char?", isLispValTest isLispValChar),
              ("port?", isLispValTest isLispValPort),
              ("procedure?", isLispValTest isLispValProcedure),
              ("pair?", isLispValTest isLispValDottedList),
              ("symbol?", isLispValTest isLispValAtom),
              ("list?", isLispValTest isLispValList),
              ("symbol->string", symbolToString),
              ("string->symbol", stringToSymbol),
              ("make-string", makeString),
              ("string", charsToString),
              ("string-ref", stringRef),
              ("substring", subString),
              ("string-append", stringAppend),
              ("string->list", stringToList),
              ("list->string", listToString),
              ("string-copy", stringCopy)]

stringCopy :: (MonadError LispError m) => [LispVal] -> m LispVal
stringCopy (s:[]) = do
    rawString <- unpackStr s
    return $ String rawString
stringCopy e = throwError $ NumArgs 1 e

listToString :: (MonadError LispError m) => [LispVal] -> m LispVal
listToString (l:[]) = do
    cs <- unpackList l
    rawChars <- mapM unpackChar cs
    return $ String rawChars
listToString e = throwError $ NumArgs 1 e

stringToList :: (MonadError LispError m) => [LispVal] -> m LispVal
stringToList (s:[]) = do
    rawString <- unpackStr s
    return $ List $ map Char rawString
stringToList e = throwError $ NumArgs 1 e

stringAppend :: (MonadError LispError m) => [LispVal] -> m LispVal
stringAppend ss@(_:_) = do
    rawStrings <- mapM unpackStr ss
    return $ String $ concat rawStrings
stringAppend e = throwError $ NumArgs 1 e

subString :: (MonadError LispError m) => [LispVal] -> m LispVal
subString (s:b:e:[]) = do
    rawString <- unpackStr s
    rawBegin <- unpackNum b
    rawEnd <- unpackNum e
    return $ String (take (fromIntegral $ rawEnd - rawBegin) (drop (fromIntegral rawBegin) rawString))
subString e = throwError $ NumArgs 3 e

stringRef :: (MonadError LispError m) => [LispVal] -> m LispVal
stringRef (s:k:[]) = do
    rawString <- unpackStr s
    rawIndex <- unpackNum k
    return $ Char (rawString !! fromIntegral rawIndex)
stringRef e = throwError $ NumArgs 2 e

makeString :: (MonadError LispError m) => [LispVal] -> m LispVal
makeString (k:[]) = do
    size <- unpackNum k
    return $ String (replicate (fromIntegral size) '.')
makeString (k:c:[]) = do
    size <- unpackNum k
    character <- unpackChar c
    return $ String (replicate (fromIntegral size) character)
makeString e = throwError $ NumArgs 2 e

charsToString :: (MonadError LispError m) => [LispVal] -> m LispVal
charsToString [] = throwError $ NumArgs 1 []
charsToString chars = do
    newString <- mapM unpackChar chars
    return $ String newString

isLispValExact :: LispVal -> Bool
isLispValExact (Number _) = True
isLispValExact (Ratio _) = True
isLispValExact _ = False

stringToSymbol :: (MonadError LispError m) => [LispVal] -> m LispVal
stringToSymbol (String s:[]) = return $ Atom s
stringToSymbol (e:[]) = throwError $ TypeMismatch "string" e
stringToSymbol e = throwError $ NumArgs 1 e

symbolToString :: (MonadError LispError m) => [LispVal] -> m LispVal
symbolToString (Atom s:[]) = return $ String s
symbolToString (e:[]) = throwError $ TypeMismatch "symbol" e
symbolToString e = throwError $ NumArgs 1 e

isLispValDottedList :: LispVal -> Bool
isLispValDottedList (DottedList _ _) = True
isLispValDottedList _ = False

isLispValProcedure :: LispVal -> Bool
isLispValProcedure (PrimitiveFunc _) = True
isLispValProcedure (IOFunc _) = True
isLispValProcedure (Func {})  = True
isLispValProcedure _ = False

isLispValPort :: LispVal -> Bool
isLispValPort (Port _) = True
isLispValPort _ = False

isLispValList :: LispVal -> Bool
isLispValList (List _) = True
isLispValList _ = False

isLispValAtom :: LispVal -> Bool
isLispValAtom (Atom _) = True
isLispValAtom _ = False

isLispValVector :: LispVal -> Bool
isLispValVector (Vector _) = True
isLispValVector _ = False

isLispValChar :: LispVal -> Bool
isLispValChar (Char _) = True
isLispValChar _ = False

isLispValInteger :: LispVal -> Bool
isLispValInteger (Number _) = True
isLispValInteger _ = False

isLispValRational :: LispVal -> Bool
isLispValRational (Number _) = True
isLispValRational (Ratio _) = True
isLispValRational _ = False

isLispValReal :: LispVal -> Bool
isLispValReal (Number _) = True
isLispValReal (Float _) = True
isLispValReal (Ratio _) = True
isLispValReal _ = False

isLispValComplex :: LispVal -> Bool
isLispValComplex (Number _) = True
isLispValComplex (Float _) = True
isLispValComplex (Ratio _) = True
isLispValComplex (Complex _) = True
isLispValComplex _ = False

isLispValNum :: LispVal -> Bool
isLispValNum (Number _) = True
isLispValNum (Float _) = True
isLispValNum (Ratio _) = True
isLispValNum (Complex _) = True
isLispValNum _ = False

isLispValBool :: LispVal -> Bool
isLispValBool (Bool _) = True
isLispValBool _ = False

isLispValString :: LispVal -> Bool
isLispValString (String _) = True
isLispValString _ = False

isLispValTest :: (MonadError LispError m) => (LispVal -> Bool) -> [LispVal] -> m LispVal
isLispValTest f (l:[]) = return $ Bool $ f l
isLispValTest _ e = throwError $ NumArgs 1 e

onlyNumListOp :: (MonadError LispError m) => (forall a. Integral a => a -> a -> a) -> [LispVal] -> m LispVal
onlyNumListOp f (l:ls@(_:_)) = foldM (onlyNumBinOp f) l ls
onlyNumListOp _ badArgList = throwError $ NumArgs 2 badArgList

onlyNumBinOp :: (MonadError LispError m) => (forall a. Integral a => a -> a -> a) -> LispVal -> LispVal -> m LispVal
onlyNumBinOp f (Number a) (Number b) = return $ Number (f a b)
onlyNumBinOp _ (Number _) e = throwError $ TypeMismatch "integral" e
onlyNumBinOp _ e _ = throwError $ TypeMismatch "integral" e

anyNumListDiv :: (MonadError LispError m) => [LispVal] -> m LispVal
anyNumListDiv (l:ls@(_:_)) = foldM anyNumBinDiv l ls
anyNumListDiv (l:[]) = anyNumBinDiv (Float 1.0) l
anyNumListDiv badArgList = throwError $ NumArgs 1 badArgList

anyNumBinDiv :: (MonadError LispError m) => LispVal -> LispVal -> m LispVal
anyNumBinDiv (Number a) (Number b) = return $ Number (div a b)
anyNumBinDiv (Number a) (Float b) = return $ Float (fromIntegral a / b)
anyNumBinDiv (Number a) (Complex b) = return $ Complex ((fromIntegral a :+ 0) / b)
anyNumBinDiv (Number a) (Ratio b) = return $ Ratio ((a % 1) / b)
anyNumBinDiv (Float a) (Number b) = return $ Float (a / fromIntegral b)
anyNumBinDiv (Float a) (Float b) = return $ Float (a / b)
anyNumBinDiv (Float a) (Complex b) = return $ Complex ((a :+ 0) / b)
anyNumBinDiv (Float a) (Ratio b) = return $ Float (a / fromRational b)
anyNumBinDiv (Complex a) (Number b) = return $ Complex (a / (fromIntegral b :+ 0))
anyNumBinDiv (Complex a) (Float b) = return $ Complex (a / (b :+ 0))
anyNumBinDiv (Complex a) (Complex b) = return $ Complex (a / b)
anyNumBinDiv (Complex a) (Ratio b) = return $ Complex (a / (fromRational b :+ 0))
anyNumBinDiv (Ratio a) (Number b) = return $ Ratio (a / (b % 1))
anyNumBinDiv (Ratio a) (Float b) = return $ Float (fromRational a / b)
anyNumBinDiv (Ratio a) (Complex b) = return $ Complex (fromRational a / b)
anyNumBinDiv (Ratio a) (Ratio b) = return $ Ratio (a / b)
anyNumBinDiv e _ = throwError $ TypeMismatch "number" e

anyNumListOp :: (MonadError LispError m) => (forall a. Num a => a -> a -> a) -> [LispVal] -> m LispVal
anyNumListOp f (l:ls@(_:_)) = foldM (anyNumBinOp f) l ls
anyNumListOp _ badArgList = throwError $ NumArgs 2 badArgList

anyNumListMinus :: (MonadError LispError m) => [LispVal] -> m LispVal
anyNumListMinus (l:ls@(_:_)) = foldM (anyNumBinOp (-)) l ls
anyNumListMinus (l:[]) = anyNumBinOp (-) (Number 0) l
anyNumListMinus badArgList = throwError $ NumArgs 1 badArgList

anyNumBinOp :: (MonadError LispError m) => (forall a. Num a => a -> a -> a) -> LispVal -> LispVal -> m LispVal
anyNumBinOp f (Number a) (Number b) = return $ Number (f a b)
anyNumBinOp f (Number a) (Float b) = return $ Float (f (fromIntegral a) b)
anyNumBinOp f (Number a) (Complex b) = return $ Complex (f (fromIntegral a :+ 0) b)
anyNumBinOp f (Number a) (Ratio b) = return $ Ratio (f (a % 1) b)
anyNumBinOp f (Float a) (Number b) = return $ Float (f a (fromIntegral b))
anyNumBinOp f (Float a) (Float b) = return $ Float (f a b)
anyNumBinOp f (Float a) (Complex b) = return $ Complex (f (a :+ 0) b)
anyNumBinOp f (Float a) (Ratio b) = return $ Float (f a (fromRational b))
anyNumBinOp f (Complex a) (Number b) = return $ Complex (f a (fromIntegral b :+ 0))
anyNumBinOp f (Complex a) (Float b) = return $ Complex (f a (b :+ 0))
anyNumBinOp f (Complex a) (Complex b) = return $ Complex (f a b)
anyNumBinOp f (Complex a) (Ratio b) = return $ Complex (f a (fromRational b :+ 0))
anyNumBinOp f (Ratio a) (Number b) = return $ Ratio (f a (b % 1))
anyNumBinOp f (Ratio a) (Float b) = return $ Float (f (fromRational a) b)
anyNumBinOp f (Ratio a) (Complex b) = return $ Complex (f (fromRational a) b)
anyNumBinOp f (Ratio a) (Ratio b) = return $ Ratio (f a b)
anyNumBinOp _ e _ = throwError $ TypeMismatch "number" e

anyEqBoolListOp :: (MonadError LispError m) => (forall a. Eq a => a -> a -> Bool) -> [LispVal] -> m LispVal
anyEqBoolListOp f ls@(_:_:_) = do
                    sequencedLispBools <- zipWithM (anyEqBoolBinOp f) ls (drop 1 ls)
                    sequencedBools <- mapM unpackBool sequencedLispBools
                    return $ Bool $ and sequencedBools
anyEqBoolListOp _ badArgList = throwError $ NumArgs 2 badArgList

anyEqBoolBinOp :: (MonadError LispError m) => (forall a. Eq a => a -> a -> Bool) -> LispVal -> LispVal -> m LispVal
anyEqBoolBinOp f (Number a) (Number b) = return $ Bool (f a b)
anyEqBoolBinOp f (Number a) (Float b) = return $ Bool (f (fromIntegral a) b)
anyEqBoolBinOp f (Number a) (Complex b) = return $ Bool (f (fromIntegral a :+ 0) b)
anyEqBoolBinOp f (Number a) (Ratio b) = return $ Bool (f (a % 1) b)
anyEqBoolBinOp f (Float a) (Number b) = return $ Bool (f a (fromIntegral b))
anyEqBoolBinOp f (Float a) (Float b) = return $ Bool (f a b)
anyEqBoolBinOp f (Float a) (Complex b) = return $ Bool (f (a :+ 0) b)
anyEqBoolBinOp f (Float a) (Ratio b) = return $ Bool (f a (fromRational b))
anyEqBoolBinOp f (Complex a) (Number b) = return $ Bool (f a (fromIntegral b :+ 0))
anyEqBoolBinOp f (Complex a) (Float b) = return $ Bool (f a (b :+ 0))
anyEqBoolBinOp f (Complex a) (Complex b) = return $ Bool (f a b)
anyEqBoolBinOp f (Complex a) (Ratio b) = return $ Bool (f a (fromRational b :+ 0))
anyEqBoolBinOp f (Ratio a) (Number b) = return $ Bool (f a (b % 1))
anyEqBoolBinOp f (Ratio a) (Float b) = return $ Bool (f (fromRational a) b)
anyEqBoolBinOp f (Ratio a) (Complex b) = return $ Bool (f (fromRational a) b)
anyEqBoolBinOp f (Ratio a) (Ratio b) = return $ Bool (f a b)
anyEqBoolBinOp _ e _ = throwError $ TypeMismatch "number" e

anyOrdBoolListOp :: (MonadError LispError m) => (forall a. Ord a => a -> a -> Bool) -> [LispVal] -> m LispVal
anyOrdBoolListOp f ls@(_:_:_) = do
                    sequencedLispBools <- zipWithM (anyOrdBoolBinOp f) ls (drop 1 ls)
                    sequencedBools <- mapM unpackBool sequencedLispBools
                    return $ Bool $ and sequencedBools
anyOrdBoolListOp _ badArgList = throwError $ NumArgs 2 badArgList

anyOrdBoolBinOp :: (MonadError LispError m) => (forall a. Ord a => a -> a -> Bool) -> LispVal -> LispVal -> m LispVal
anyOrdBoolBinOp f (Number a) (Number b) = return $ Bool (f a b)
anyOrdBoolBinOp f (Number a) (Float b) = return $ Bool (f (fromIntegral a) b)
anyOrdBoolBinOp f (Number a) (Ratio b) = return $ Bool (f (a % 1) b)
anyOrdBoolBinOp f (Float a) (Number b) = return $ Bool (f a (fromIntegral b))
anyOrdBoolBinOp f (Float a) (Float b) = return $ Bool (f a b)
anyOrdBoolBinOp f (Float a) (Ratio b) = return $ Bool (f a (fromRational b))
anyOrdBoolBinOp _ e@(Complex _) _ = throwError $ TypeMismatch "ordered" e
anyOrdBoolBinOp _ _ e@(Complex _) = throwError $ TypeMismatch "ordered" e
anyOrdBoolBinOp f (Ratio a) (Number b) = return $ Bool (f a (b % 1))
anyOrdBoolBinOp f (Ratio a) (Float b) = return $ Bool (f (fromRational a) b)
anyOrdBoolBinOp f (Ratio a) (Ratio b) = return $ Bool (f a b)
anyOrdBoolBinOp _ e _ = throwError $ TypeMismatch "number" e

boolBinop :: (MonadError LispError m) => (LispVal -> m a) -> (a -> a -> Bool) -> [LispVal] -> m LispVal
boolBinop unpacker op args = if length args /= 2
                             then throwError $ NumArgs 2 args
                             else do left <- unpacker $ head args
                                     right <- unpacker $ args !! 1
                                     return $ Bool $ left `op` right

strBoolBinop :: (MonadError LispError m) => (String -> String -> Bool) -> [LispVal] -> m LispVal
strBoolBinop = boolBinop unpackStr
boolBoolBinop :: (MonadError LispError m) => (Bool -> Bool -> Bool) -> [LispVal] -> m LispVal
boolBoolBinop = boolBinop unpackBool

unpackChar :: (MonadError LispError m) => LispVal -> m Char
unpackChar (Char c) = return c
unpackChar notChar = throwError $ TypeMismatch "character" notChar

unpackList :: (MonadError LispError m) => LispVal -> m [LispVal]
unpackList (List l) = return l
unpackList notList = throwError $ TypeMismatch "list" notList

unpackNum :: (MonadError LispError m) => LispVal -> m Integer
unpackNum (Number n) = return n
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum

unpackComplex :: (MonadError LispError m) => LispVal -> m (Complex Float)
unpackComplex (Complex n) = return n
unpackComplex (Number n) = return (fromIntegral n :+ 0)
unpackComplex (Float n) = return (n :+ 0)
unpackComplex (Ratio n) = return (fromRational n :+ 0)
unpackComplex (List [n]) = unpackComplex n
unpackComplex notNum = throwError $ TypeMismatch "number" notNum

unpackRatio :: (MonadError LispError m) => LispVal -> m (Ratio Integer)
unpackRatio (Ratio n) = return n
unpackRatio (Number n) = return (n % 1)
unpackRatio (List [n]) = unpackRatio n
unpackRatio notNum = throwError $ TypeMismatch "number" notNum

unpackFloat :: (MonadError LispError m) => LispVal -> m Float
unpackFloat (Float n) = return n
unpackFloat (Ratio n) = return (fromRational n)
unpackFloat (Number n) = return (fromIntegral n)
unpackFloat (List [n]) = unpackFloat n
unpackFloat notNum = throwError $ TypeMismatch "number" notNum

unpackStr :: (MonadError LispError m) => LispVal -> m String
unpackStr (String s) = return s
unpackStr notString = throwError $ TypeMismatch "string" notString

unpackCoerceStr :: (MonadError LispError m) => LispVal -> m String
unpackCoerceStr (String s) = return s
unpackCoerceStr (Number s) = return $ show s
unpackCoerceStr (Complex s) = return $ show s
unpackCoerceStr (Float s) = return $ show s
unpackCoerceStr (Ratio s) = return $ show s
unpackCoerceStr b@(Bool _) = return $ show b
unpackCoerceStr notString = throwError $ TypeMismatch "string" notString

unpackBool :: (MonadError LispError m) => LispVal -> m Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool

car :: (MonadError LispError m) => [LispVal] -> m LispVal
car [List (x:_)] = return x
car [DottedList (x:_) _] = return x
car [badArg] = throwError $ TypeMismatch "pair" badArg
car badArgList = throwError $ NumArgs 1 badArgList

cdr :: (MonadError LispError m) => [LispVal] -> m LispVal
cdr [List (_ : xs)] = return $ List xs
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [DottedList _ x] = return x
cdr [badArg] = throwError $ TypeMismatch "pair" badArg
cdr badArgList = throwError $ NumArgs 1 badArgList

cons :: (MonadError LispError m) => [LispVal] -> m LispVal
cons [x1, List []] = return $ List [x1]
cons [x, List xs] = return $ List $ x : xs
cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast
cons [x1, x2] = return $ DottedList [x1] x2
cons badArgList = throwError $ NumArgs 2 badArgList

eqv :: (MonadError LispError m) => [LispVal] -> m LispVal
eqv [Bool arg1, Bool arg2] = return $ Bool $ arg1 == arg2
eqv [Number arg1, Number arg2] = return $ Bool $ arg1 == arg2
eqv [Ratio arg1, Ratio arg2] = return $ Bool $ arg1 == arg2
eqv [Float arg1, Float arg2] = return $ Bool $ arg1 == arg2
eqv [Complex arg1, Complex arg2] = return $ Bool $ arg1 == arg2
eqv [String arg1, String arg2] = return $ Bool $ arg1 == arg2
eqv [Atom arg1, Atom arg2] = return $ Bool $ arg1 == arg2
eqv [DottedList xs x, DottedList ys y] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [List arg1, List arg2] = return $ Bool $ (length arg1 == length arg2) &&
                                                    all eqvPair (zip arg1 arg2)
    where eqvPair (x1, x2) = case eqv [x1, x2] of
                               Left _ -> False
                               Right (Bool val) -> val
                               Right _ -> False
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList

data EqUnpacker m = forall a. Eq a => AnyEqUnpacker (LispVal -> m a)

unpackEquals :: (MonadError LispError m) => LispVal -> LispVal -> EqUnpacker m -> m Bool
unpackEquals arg1 arg2 (AnyEqUnpacker unpacker) =
             do unpacked1 <- unpacker arg1
                unpacked2 <- unpacker arg2
                return $ unpacked1 == unpacked2
        `catchError` const (return False)

equal :: (MonadError LispError m) => [LispVal] -> m LispVal
equal [List arg1, List arg2] = return $ Bool $ (length arg1 == length arg2) &&
                                                    all eqvPair (zip arg1 arg2)
    where eqvPair (x1, x2) = case equal [x1, x2] of
                               Right (Bool val) -> val
                               _ -> False
equal [arg1, arg2] = do
    primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
                      [AnyEqUnpacker unpackNum, AnyEqUnpacker unpackRatio, AnyEqUnpacker unpackFloat,
                        AnyEqUnpacker unpackComplex, AnyEqUnpacker unpackCoerceStr, AnyEqUnpacker unpackBool]
    eqvEquals <- eqv [arg1, arg2]
    return $ Bool (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList

makePort ::(MonadError LispError m, MonadIO m) =>  IOMode -> [LispVal] -> m LispVal
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
makePort _ [e] = throwError $ TypeMismatch "string" e
makePort _ e = throwError $ NumArgs 1 e

closePort :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
closePort [Port port] = liftIO $ hClose port >> return (Bool True)
closePort _ = return $ Bool False

readProc :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
readProc [] = readProc [Port stdin]
readProc [Port _] = liftIO getLine >>= readExpr
readProc [e] = throwError $ TypeMismatch "port" e
readProc e = throwError $ NumArgs 1 e

writeProc :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
writeProc [obj] = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> return (Bool True)
writeProc [_, e] = throwError $ TypeMismatch "port" e
writeProc e = throwError $ NumArgs 2 e

readContents :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
readContents [String filename] = liftM String $ liftIO $ readFile filename
readContents [e] = throwError $ TypeMismatch "string" e
readContents e = throwError $ NumArgs 1 e

readAll :: (MonadError LispError m, MonadIO m) => [LispVal] -> m LispVal
readAll [String filename] = liftM List $ load filename
readAll [e] = throwError $ TypeMismatch "string" e
readAll e = throwError $ NumArgs 1 e

load :: (MonadIO m, MonadError LispError m) => String -> m [LispVal]
load filename = liftIO (readFile filename) >>= readExprList

ifProc :: [LispVal] -> LispEval
ifProc [p, conseq, alt] =
    do result <- eval p
       case result of
         Bool False -> eval alt
         _ -> eval conseq
ifProc [p, conseq] =
    do result <- eval p
       case result of
         Bool False -> return Void --if without an else - no value
         _ -> eval conseq
ifProc e = throwError $ NumArgs 2 e

condProc :: [LispVal] -> LispEval
condProc (clause:cs) =
    foldl (chainEvalClause evalCondClause) (evalCondClause clause) cs
        `catchError` (\e -> case e of
            WrongClause -> return Void -- no matching cond - no value
            _ -> throwError e)
condProc e = throwError $ NumArgs 1 e
caseProc :: [LispVal] -> LispEval
caseProc (key:clause:cs) = do
    evalKey <- eval key
    foldl (chainEvalClause (evalCaseClause evalKey)) (evalCaseClause evalKey clause) cs
        `catchError` (\e -> case e of
            WrongClause -> return Void -- no matching case - no value
            _ -> throwError e)
caseProc e = throwError $ NumArgs 2 e

chainEvalClause :: (LispVal -> LispEval) -> LispEval -> LispVal -> LispEval
chainEvalClause evalFunc evalC unevalC =
    evalC `catchError` (\e ->
        case e of
            WrongClause -> evalFunc unevalC
            _ -> throwError e)

evalCaseClause :: LispVal -> LispVal -> LispEval
evalCaseClause key (List (datums:(exprs@(_:_)))) = --exprs can't be []
    case datums of
        Atom "else" -> do
                evalExprs <- mapM eval exprs
                return $ last evalExprs
        List l -> do success <- liftM or $ mapM (\x -> eqv [x, key] >>= unpackBool) l
                     if success
                        then do
                            evalExprs <- mapM eval exprs
                            return $ last evalExprs
                        else throwError WrongClause
        e -> throwError $ TypeMismatch "list" e
evalCaseClause _ badForm = throwError $ BadSpecialForm "Unrecognized case clause form" badForm

evalCondClause :: LispVal -> LispEval
evalCondClause (List (test:[])) =
    do success <- eval test
       case success of
            Bool True -> return success
            Bool False -> throwError WrongClause
            _ -> throwError $ TypeMismatch "boolean" success
evalCondClause (List (test:exprs)) =
    case test of
        Atom "else" -> do
            evalExprs <- mapM eval exprs
            return $ last evalExprs
        _ -> do success <- eval test
                case success of
                    Bool True -> do
                        evalExprs <- mapM eval exprs
                        return $ last evalExprs
                    Bool False -> throwError WrongClause
                    _ -> throwError $ TypeMismatch "boolean" success
evalCondClause badForm = throwError $ BadSpecialForm "Unrecognized cond clause form" badForm

setProc :: [LispVal] -> LispEval
setProc [Atom var, form] = eval form >>= setVar var
setProc e = throwError $ NumArgs 2 e

stringSetProc :: [LispVal] -> LispEval
stringSetProc [Atom var, i, ch] =
    do i' <- eval i
       index <- unpackNum i'
       ch' <- eval ch
       char <- unpackChar ch'
       v <- getVar var
       str <- unpackStr v
       let (f,s) = splitAt (fromIntegral index) str
       case s of
            [] -> throwError $ Unspecified "invalid index"
            _ -> setVar var (String $ f ++ [char] ++ drop 1 s)
stringSetProc e = throwError $ NumArgs 3 e

stringFillProc :: [LispVal] -> LispEval
stringFillProc [Atom var, ch] =
    do v <- getVar var
       ch' <- eval ch
       char <- unpackChar ch'
       str <- unpackStr v
       setVar var (String $ map (const char) str)
stringFillProc e = throwError $ NumArgs 2 e

defineProc :: [LispVal] -> LispEval
defineProc [Atom var, form] = eval form >>= defineVar var
defineProc (List (Atom var : p) : b) =
    makeNormalFunc p b >>= defineVar var
defineProc (DottedList (Atom var : p) varargs : b) =
    makeVarargs varargs p b >>= defineVar var
defineProc e = throwError $ NumArgs 2 e

callCCProc :: [LispVal] -> LispEval
callCCProc [proc] =
    callCC $ \cont -> do
        f <- eval proc
        applyProc' [f, Continuation cont]
callCCProc e = throwError $ NumArgs 1 e

lambdaProc :: [LispVal] -> LispEval
lambdaProc (List p : b) = makeNormalFunc p b
lambdaProc (DottedList p varargs : b) =
    makeVarargs varargs p b
lambdaProc (varargs@(Atom _) : b) =
    makeVarargs varargs [] b
lambdaProc e = throwError $ NumArgs 2 e

makeFunc :: Maybe String -> [LispVal] -> [LispVal] -> LispEval
makeFunc varargs p b = do
    env <- getEnv
    return $ Func (map show p) varargs b env

makeNormalFunc :: [LispVal] -> [LispVal] -> LispEval
makeNormalFunc = makeFunc Nothing

makeVarargs :: LispVal -> [LispVal] -> [LispVal] -> LispEval
makeVarargs = makeFunc . Just . show

loadProc :: [LispVal] -> LispEval
loadProc [String filename] =
    load filename >>= liftM last . mapM eval
loadProc e = throwError $ NumArgs 1 e

applyProc :: [LispVal] -> LispEval
applyProc args = do
    argVals <- mapM eval args
    applyProc' argVals

applyProc' :: [LispVal] -> LispEval
applyProc' [func, List args] = apply func args
applyProc' (func : args) = apply func args
applyProc' e = throwError $ NumArgs 2 e


{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

--
-- 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.
--

module Feldspar.Core.Types
       ( module Feldspar.Core.Types
       , IntN(..), WordN(..)
       , tuple, Tuple(), RTuple(..), sel, Skip(..), First(..), (:*), TNil -- From NestedTuples
       ) where

import Data.Array.IO (IOArray(..))
import Data.Bits
import Data.Complex
import Data.Int
import Data.IORef
import Data.List
import Data.Typeable (Typeable)
import Data.Orphans
import Data.Word
import Data.Hash
import Test.QuickCheck
import System.Random (Random(..))
import qualified Control.Monad.Par as MonadPar

import Data.Patch
import Data.Proxy

import Feldspar.Lattice
import Feldspar.Range
import Feldspar.Core.NestedTuples

--------------------------------------------------------------------------------
-- * Heterogenous lists
--------------------------------------------------------------------------------

-- | Heterogeneous list
data a :> b = a :> b
  deriving (Eq, Ord, Show)

infixr 5 :>

instance (Lattice a, Lattice b) => Lattice (a :> b)
  where
    bot = bot :> bot
    top = top :> top
    (a1:>a2) \/ (b1:>b2) = (a1 \/ b1) :> (a2 \/ b2)
    (a1:>a2) /\ (b1:>b2) = (a1 /\ b1) :> (a2 /\ b2)

-- | Type representation of 8 bits
data N8

-- | Type representation of 16 bits
data N16

-- | Type representation of 32 bits
data N32

-- | Type representation of 64 bits
data N64

-- | Type representation of the native number of bits on the target
data NNative

-- | Witness for 'N8', 'N16', 'N32', 'N64' or 'NNative'
data BitWidth n
  where
    N8      :: BitWidth N8
    N16     :: BitWidth N16
    N32     :: BitWidth N32
    N64     :: BitWidth N64
    NNative :: BitWidth NNative

bitWidth :: BitWidth n -> String
bitWidth N8      = "8"
bitWidth N16     = "16"
bitWidth N32     = "32"
bitWidth N64     = "64"
bitWidth NNative = "N"

-- | Type representation of \"unsigned\"
data U

-- | Type representation of \"signed\"
data S

-- | Witness for 'U' or 'S'
data Signedness s
  where
    U :: Signedness U
    S :: Signedness S

signedness :: Signedness s -> String
signedness U = "Word"
signedness S = "Int"

-- | A generalization of unsigned and signed integers. The first parameter
-- represents the signedness and the second parameter the number of bits.
type family GenericInt s n where
  GenericInt U N8      = Word8
  GenericInt S N8      = Int8
  GenericInt U N16     = Word16
  GenericInt S N16     = Int16
  GenericInt U N32     = Word32
  GenericInt S N32     = Int32
  GenericInt U N64     = Word64
  GenericInt S N64     = Int64
  GenericInt U NNative = WordN
  GenericInt S NNative = IntN

fromWordN :: BitWidth n -> WordN -> GenericInt U n
fromWordN N8      = fromInteger . toInteger
fromWordN N16     = fromInteger . toInteger
fromWordN N32     = fromInteger . toInteger
fromWordN N64     = fromInteger . toInteger
fromWordN NNative = id
  -- TODO Check that the number fits

fromIntN :: BitWidth n -> IntN -> GenericInt S n
fromIntN N8      = fromInteger . toInteger
fromIntN N16     = fromInteger . toInteger
fromIntN N32     = fromInteger . toInteger
fromIntN N64     = fromInteger . toInteger
fromIntN NNative = id
  -- TODO Check that the number fits

genericLen :: BitWidth n -> [a] -> GenericInt U n
genericLen N8      = genericLength
genericLen N16     = genericLength
genericLen N32     = genericLength
genericLen N64     = genericLength
genericLen NNative = genericLength

type Length = WordN
type Index  = WordN

--------------------------------------------------------------------------------
-- * Arrays
--------------------------------------------------------------------------------

-- | Array whose length is represented by an @n@-bit word
data TargetArr n a = TargetArr (GenericInt U n) [a]

--------------------------------------------------------------------------------
-- * Monadic Types
--------------------------------------------------------------------------------

-- | This class is used to allow constructs to be abstract in the monad
class MonadType m
  where
    voidTypeRep :: TypeRep (m ())
  -- TODO Since the `Mut` monad is already abstract, this class is probably only
  --      needed if we want to be able to use monadic constructs with different
  --      monad types.

--------------------------------------------------------------------------------
-- * Mutable data
--------------------------------------------------------------------------------

-- TODO Make newtypes?

-- | Monad for manipulation of mutable data
type Mut = IO

-- | Mutable references
instance Show (IORef a)
  where
    show _ = "IORef"

-- | Mutable arrays
type MArr a = IOArray Integer a

instance Show (MArr a)
  where
    show _ = "MArr"

instance MonadType Mut
  where
    voidTypeRep = MutType UnitType

--------------------------------------------------------------------------------
-- * Par Monad
--------------------------------------------------------------------------------

-- | Monad for parallel constructs
type Par = MonadPar.Par

deriving instance Typeable Par

-- | Immutable references
type IV = MonadPar.IVar

instance Show (IV a)
  where
    show _ = "IVar"

instance MonadType Par
  where
    voidTypeRep = ParType UnitType

--------------------------------------------------------------------------------
-- * Elements Language
--------------------------------------------------------------------------------

newtype Elements a = Elements { unE :: [(Index, a)] }

deriving instance Typeable Elements

instance Show a => Show (Elements a)
  where
    show (Elements a) = "Elements " ++ show a

instance Eq a => Eq (Elements a)
  where
    _ == _ = False

--------------------------------------------------------------------------------
-- * Future values
--------------------------------------------------------------------------------

newtype FVal a = FVal {unFVal :: a}

deriving instance Typeable IV
deriving instance Typeable FVal

instance Show (FVal a)
  where
    show _ = "future"

instance Eq a => Eq (FVal a)
  where
    (FVal a) == (FVal b) = a == b

--------------------------------------------------------------------------------
-- * Hashing
--------------------------------------------------------------------------------

instance Hashable a => Hashable (Complex a) where
  hash (re :+ im) = hash re `combine` hash im

--------------------------------------------------------------------------------
-- * Type representation
--------------------------------------------------------------------------------

-- | Representation of supported types
data TypeRep a
  where
    UnitType      :: TypeRep ()
    BoolType      :: TypeRep Bool
    IntType       :: ( BoundedInt (GenericInt s n)
                     , Size (GenericInt s n) ~ Range (GenericInt s n)
                     ) =>
                       Signedness s -> BitWidth n -> TypeRep (GenericInt s n)
    FloatType     :: TypeRep Float
    DoubleType    :: TypeRep Double
    ComplexType   :: RealFloat a => TypeRep a -> TypeRep (Complex a)
    ArrayType     :: TypeRep a -> TypeRep [a]
    TargetArrType :: BitWidth n -> TypeRep a -> TypeRep (TargetArr n a)
    Tup2Type      :: TypeRep a -> TypeRep b -> TypeRep (a,b)
    Tup3Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep (a,b,c)
    Tup4Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep (a,b,c,d)
    Tup5Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep (a,b,c,d,e)
    Tup6Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep (a,b,c,d,e,f)
    Tup7Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep (a,b,c,d,e,f,g)
    Tup8Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep (a,b,c,d,e,f,g,h)
    Tup9Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep (a,b,c,d,e,f,g,h,i)
    Tup10Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep (a,b,c,d,e,f,g,h,i,j)
    Tup11Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep (a,b,c,d,e,f,g,h,i,j,k)
    Tup12Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep l -> TypeRep (a,b,c,d,e,f,g,h,i,j,k,l)
    Tup13Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep l -> TypeRep m -> TypeRep (a,b,c,d,e,f,g,h,i,j,k,l,m)
    Tup14Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep l -> TypeRep m -> TypeRep n -> TypeRep (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
    Tup15Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep h -> TypeRep i -> TypeRep j -> TypeRep k -> TypeRep l -> TypeRep m -> TypeRep n -> TypeRep o -> TypeRep (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)
    FunType       :: TypeRep a -> TypeRep b -> TypeRep (a -> b)
    MutType       :: TypeRep a -> TypeRep (Mut a)
    RefType       :: TypeRep a -> TypeRep (IORef a)
    MArrType      :: TypeRep a -> TypeRep (MArr a)
    ParType       :: TypeRep a -> TypeRep (Par a)
    ElementsType  :: TypeRep a -> TypeRep (Elements a)
    ConsType      :: TypeRep a -> TypeRep (RTuple b) -> TypeRep (RTuple (a :* b))
    NilType       :: TypeRep (RTuple TNil)
    TupleType     :: TypeRep (RTuple a) -> TypeRep (Tuple a)
    IVarType      :: TypeRep a -> TypeRep (IV a)
    FValType      :: TypeRep a -> TypeRep (FVal a)
      -- TODO `MArrType` Should have a target-specialized version. Or perhaps
      --      use a single type with a flag to distinguish between immutable and
      --      mutable arrays.

instance Show (TypeRep a)
  where
    show UnitType            = "()"
    show BoolType            = "Bool"
    show (IntType s n)       = signedness s ++ bitWidth n
    show FloatType           = "Float"
    show DoubleType          = "Double"
    show (ComplexType t)     = "(Complex " ++ show t ++ ")"
    show (ArrayType t)       = "[" ++ show t ++ "]"
    show (TargetArrType _ t) = "[" ++ show t ++ "]"
    show (Tup2Type ta tb)                = showTup [show ta, show tb]
    show (Tup3Type ta tb tc)             = showTup [show ta, show tb, show tc]
    show (Tup4Type ta tb tc td)          = showTup [show ta, show tb, show tc, show td]
    show (Tup5Type ta tb tc td te)       = showTup [show ta, show tb, show tc, show td, show te]
    show (Tup6Type ta tb tc td te tf)    = showTup [show ta, show tb, show tc, show td, show te, show tf]
    show (Tup7Type ta tb tc td te tf tg) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg]
    show (Tup8Type ta tb tc td te tf tg th) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th]
    show (Tup9Type ta tb tc td te tf tg th ti) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti]
    show (Tup10Type ta tb tc td te tf tg th ti tj) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj]
    show (Tup11Type ta tb tc td te tf tg th ti tj tk) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk]
    show (Tup12Type ta tb tc td te tf tg th ti tj tk tl) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk, show tl]
    show (Tup13Type ta tb tc td te tf tg th ti tj tk tl tm) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk, show tl, show tm]
    show (Tup14Type ta tb tc td te tf tg th ti tj tk tl tm tn) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk, show tl, show tm, show tn]
    show (Tup15Type ta tb tc td te tf tg th ti tj tk tl tm tn to) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg, show th, show ti, show tj, show tk, show tl, show tm, show tn, show to]
    show (FunType ta tb)                 = show ta ++ " -> " ++ show tb
    show (MutType ta)                    = unwords ["Mut", show ta]
    show (RefType ta)                    = unwords ["Ref", show ta]
    show (MArrType ta)                   = unwords ["MArr", show ta]
    show (ParType ta)                    = unwords ["Par", show ta]
    show (ElementsType ta)               = unwords ["Elements", show ta]
    show (ConsType ta tb)                = unwords [show ta, ":*", show tb]
    show NilType                         = "TNil"
    show (TupleType t)                   = "<" ++ show t ++ ">"
    show (IVarType ta)                   = unwords ["IVar", show ta]
    show (FValType ta)                   = unwords ["FVal", show ta]

-- | Type equality witness
data TypeEq a b
  where
    TypeEq :: TypeEq a a

defaultSize :: TypeRep a -> Size a
defaultSize UnitType = universal
defaultSize BoolType = universal
defaultSize (IntType _ _) = universal
defaultSize FloatType = universal
defaultSize DoubleType = universal
defaultSize (ComplexType _) = universal
defaultSize (ArrayType t) = universal :> defaultSize t
--defaultSize (TargetArrType n t) = universal :> defaultSize t -- TODO
defaultSize (Tup2Type ta tb) =  ( defaultSize ta
                                , defaultSize tb
                                )
defaultSize (Tup3Type ta tb tc) = ( defaultSize ta
                                  , defaultSize tb
                                  , defaultSize tc
                                  )
defaultSize (Tup4Type ta tb tc td) = ( defaultSize ta
                                     , defaultSize tb
                                     , defaultSize tc
                                     , defaultSize td
                                     )
defaultSize (Tup5Type ta tb tc td te) = ( defaultSize ta
                                        , defaultSize tb
                                        , defaultSize tc
                                        , defaultSize td
                                        , defaultSize te
                                        )
defaultSize (Tup6Type ta tb tc td te tf) = ( defaultSize ta
                                           , defaultSize tb
                                           , defaultSize tc
                                           , defaultSize td
                                           , defaultSize te
                                           , defaultSize tf
                                           )
defaultSize (Tup7Type ta tb tc td te tf tg) = ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              )
defaultSize (Tup8Type ta tb tc td te tf tg th) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              )
defaultSize (Tup9Type ta tb tc td te tf tg th ti) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              )
defaultSize (Tup10Type ta tb tc td te tf tg th ti tj) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              )
defaultSize (Tup11Type ta tb tc td te tf tg th ti tj tk) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              )
defaultSize (Tup12Type ta tb tc td te tf tg th ti tj tk tl) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              , defaultSize tl
                                              )
defaultSize (Tup13Type ta tb tc td te tf tg th ti tj tk tl tm) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              , defaultSize tl
                                              , defaultSize tm
                                              )
defaultSize (Tup14Type ta tb tc td te tf tg th ti tj tk tl tm tn) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              , defaultSize tl
                                              , defaultSize tm
                                              , defaultSize tn
                                              )
defaultSize (Tup15Type ta tb tc td te tf tg th ti tj tk tl tm tn to) =
                                              ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              , defaultSize th
                                              , defaultSize ti
                                              , defaultSize tj
                                              , defaultSize tk
                                              , defaultSize tl
                                              , defaultSize tm
                                              , defaultSize tn
                                              , defaultSize to
                                              )
defaultSize (FunType ta tb) = (defaultSize ta, defaultSize tb)
defaultSize (MutType ta) = defaultSize ta
defaultSize (RefType ta) = defaultSize ta
defaultSize (MArrType ta) = universal :> defaultSize ta
defaultSize (ParType ta) = defaultSize ta
defaultSize (ElementsType ta) = universal :> defaultSize ta
defaultSize (ConsType ta tb) = (defaultSize ta, defaultSize tb)
defaultSize NilType = universal
defaultSize (TupleType t) = defaultSize t
defaultSize (IVarType ta) = defaultSize ta
defaultSize (FValType ta) = defaultSize ta

-- | Type equality on 'Signedness'
signEq :: Signedness s1 -> Signedness s2 -> Maybe (TypeEq s1 s2)
signEq U U = Just TypeEq
signEq S S = Just TypeEq
signEq _ _ = Nothing

-- | Type equality on 'BitWidth'
widthEq :: BitWidth n1 -> BitWidth n2 -> Maybe (TypeEq n1 n2)
widthEq N8      N8      = Just TypeEq
widthEq N16     N16     = Just TypeEq
widthEq N32     N32     = Just TypeEq
widthEq N64     N64     = Just TypeEq
widthEq NNative NNative = Just TypeEq
widthEq _ _ = Nothing

-- | Type equality on 'TypeRep'
typeEq :: TypeRep a -> TypeRep b -> Maybe (TypeEq a b)
typeEq UnitType UnitType = Just TypeEq
typeEq BoolType BoolType = Just TypeEq
typeEq (IntType s1 n1) (IntType s2 n2) = do
    TypeEq <- signEq s1 s2
    TypeEq <- widthEq n1 n2
    return TypeEq
typeEq FloatType FloatType = Just TypeEq
typeEq DoubleType DoubleType = Just TypeEq
typeEq (ComplexType t1) (ComplexType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (ArrayType t1) (ArrayType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (TargetArrType n1 t1) (TargetArrType n2 t2) = do
    TypeEq <- widthEq n1 n2
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (Tup2Type a1 b1) (Tup2Type a2 b2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    return TypeEq
typeEq (Tup3Type a1 b1 c1) (Tup3Type a2 b2 c2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    return TypeEq
typeEq (Tup4Type a1 b1 c1 d1) (Tup4Type a2 b2 c2 d2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    return TypeEq
typeEq (Tup5Type a1 b1 c1 d1 e1) (Tup5Type a2 b2 c2 d2 e2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    return TypeEq
typeEq (Tup6Type a1 b1 c1 d1 e1 f1) (Tup6Type a2 b2 c2 d2 e2 f2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    return TypeEq
typeEq (Tup7Type a1 b1 c1 d1 e1 f1 g1) (Tup7Type a2 b2 c2 d2 e2 f2 g2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    return TypeEq
typeEq (Tup8Type a1 b1 c1 d1 e1 f1 g1 h1) (Tup8Type a2 b2 c2 d2 e2 f2 g2 h2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    return TypeEq
typeEq (Tup9Type a1 b1 c1 d1 e1 f1 g1 h1 i1) (Tup9Type a2 b2 c2 d2 e2 f2 g2 h2 i2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    return TypeEq
typeEq (Tup10Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1) (Tup10Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    return TypeEq
typeEq (Tup11Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1) (Tup11Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    return TypeEq
typeEq (Tup12Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1) (Tup12Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    TypeEq <- typeEq l1 l2
    return TypeEq
typeEq (Tup13Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1) (Tup13Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    TypeEq <- typeEq l1 l2
    TypeEq <- typeEq m1 m2
    return TypeEq
typeEq (Tup14Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1) (Tup14Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    TypeEq <- typeEq l1 l2
    TypeEq <- typeEq m1 m2
    TypeEq <- typeEq n1 n2
    return TypeEq
typeEq (Tup15Type a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1 o1) (Tup15Type a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 o2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    TypeEq <- typeEq h1 h2
    TypeEq <- typeEq i1 i2
    TypeEq <- typeEq j1 j2
    TypeEq <- typeEq k1 k2
    TypeEq <- typeEq l1 l2
    TypeEq <- typeEq m1 m2
    TypeEq <- typeEq n1 n2
    TypeEq <- typeEq o1 o2
    return TypeEq
typeEq (FunType a1 b1) (FunType a2 b2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    return TypeEq
typeEq (MutType t1) (MutType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (RefType t1) (RefType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (MArrType a1) (MArrType a2) = do
    TypeEq <- typeEq a1 a2
    return TypeEq
typeEq (ParType t1) (ParType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (ElementsType t1) (ElementsType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (ConsType a1 b1) (ConsType a2 b2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    return TypeEq
typeEq NilType NilType = do
    return TypeEq
typeEq (TupleType t1) (TupleType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (IVarType t1) (IVarType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (FValType t1) (FValType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq _ _ = Nothing

showTup :: [String] -> String
showTup as =  "(" ++ intercalate "," as ++ ")"

type family TargetType n a where
  TargetType n ()              = ()
  TargetType n Bool            = Bool
  TargetType n Word8           = Word8
  TargetType n Int8            = Int8
  TargetType n Word16          = Word16
  TargetType n Int16           = Int16
  TargetType n Word32          = Word32
  TargetType n Int32           = Int32
  TargetType n Word64          = Word64
  TargetType n Int64           = Int64
  TargetType n WordN           = GenericInt U n
  TargetType n IntN            = GenericInt S n
  TargetType n Float           = Float
  TargetType n Double          = Double
  TargetType n (Complex a)     = Complex (TargetType n a)
  TargetType n [a]             = TargetArr n (TargetType n a)
  TargetType n (a,b)           = (TargetType n a, TargetType n b)
  TargetType n (a,b,c)         = (TargetType n a, TargetType n b, TargetType n c)
  TargetType n (a,b,c,d)       = (TargetType n a, TargetType n b, TargetType n c, TargetType n d)
  TargetType n (a,b,c,d,e)     = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e)
  TargetType n (a,b,c,d,e,f)   = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f)
  TargetType n (a,b,c,d,e,f,g) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g)
  TargetType n (a,b,c,d,e,f,g,h) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h)
  TargetType n (a,b,c,d,e,f,g,h,i) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i)
  TargetType n (a,b,c,d,e,f,g,h,i,j) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j)
  TargetType n (a,b,c,d,e,f,g,h,i,j,k) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k)
  TargetType n (a,b,c,d,e,f,g,h,i,j,k,l) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k, TargetType n l)
  TargetType n (a,b,c,d,e,f,g,h,i,j,k,l,m) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k, TargetType n l, TargetType n m)
  TargetType n (a,b,c,d,e,f,g,h,i,j,k,l,m,n') = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k, TargetType n l, TargetType n m, TargetType n n')
  TargetType n (a,b,c,d,e,f,g,h,i,j,k,l,m,n',o) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g, TargetType n h, TargetType n i, TargetType n j, TargetType n k, TargetType n l, TargetType n m, TargetType n n', TargetType n o)
  TargetType n (IORef a)       = IORef (TargetType n a)
  TargetType n (MArr a)        = MArr (TargetType n a)
  TargetType n (Elements a)    = Elements (TargetType n a)
  TargetType n (RTuple (a:*b)) = RTuple (TargetType n a :* TargetType n b)
  TargetType n (RTuple TNil)   = Tuple TNil
  TargetType n (Tuple a)       = Tuple (TargetType n a)
  TargetType n (IV a)          = IV (TargetType n a)
  TargetType n (FVal a)        = FVal (TargetType n a)

-- | The set of supported types
class (Eq a, Show a, Typeable a, Show (Size a), Lattice (Size a), TypeF a) => Type a
  where
    -- | Gives the type representation a value.
    typeRep  :: TypeRep a
    sizeOf   :: a -> Size a
    toTarget :: BitWidth n -> a -> TargetType n a

instance Type ()      where typeRep = UnitType;          sizeOf _ = AnySize;      toTarget _ = id
instance Type Bool    where typeRep = BoolType;          sizeOf _ = AnySize;      toTarget _ = id
instance Type Word8   where typeRep = IntType U N8;      sizeOf = singletonRange; toTarget _ = id
instance Type Int8    where typeRep = IntType S N8;      sizeOf = singletonRange; toTarget _ = id
instance Type Word16  where typeRep = IntType U N16;     sizeOf = singletonRange; toTarget _ = id
instance Type Int16   where typeRep = IntType S N16;     sizeOf = singletonRange; toTarget _ = id
instance Type Word32  where typeRep = IntType U N32;     sizeOf = singletonRange; toTarget _ = id
instance Type Int32   where typeRep = IntType S N32;     sizeOf = singletonRange; toTarget _ = id
instance Type Word64  where typeRep = IntType U N64;     sizeOf = singletonRange; toTarget _ = id
instance Type Int64   where typeRep = IntType S N64;     sizeOf = singletonRange; toTarget _ = id
instance Type WordN   where typeRep = IntType U NNative; sizeOf = singletonRange; toTarget = fromWordN
instance Type IntN    where typeRep = IntType S NNative; sizeOf = singletonRange; toTarget = fromIntN
instance Type Float   where typeRep = FloatType;         sizeOf _ = AnySize;      toTarget _ = id
instance Type Double  where typeRep = DoubleType;        sizeOf _ = AnySize;      toTarget _ = id

instance (Type a, RealFloat a) => Type (Complex a)
  where
    typeRep             = ComplexType typeRep
    sizeOf _            = AnySize
    toTarget _ (_ :+ _) = error "TODO" -- toTarget n r :+ toTarget n i

instance Type a => Type [a]
  where
    typeRep       = ArrayType typeRep
    sizeOf as     = singletonRange (genericLength as) :> unions (map sizeOf as)
    toTarget n as = TargetArr (genericLen n as) $ map (toTarget n) as

instance (Type a, Type b) => Type (a,b)
  where
    typeRep = Tup2Type typeRep typeRep

    sizeOf (a,b) =
        ( sizeOf a
        , sizeOf b
        )

    toTarget n (a,b) =
        ( toTarget n a
        , toTarget n b
        )

instance (Type a, Type b, Type c) => Type (a,b,c)
  where
    typeRep = Tup3Type typeRep typeRep typeRep

    sizeOf (a,b,c) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        )

    toTarget n (a,b,c) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        )

instance (Type a, Type b, Type c, Type d) => Type (a,b,c,d)
  where
    typeRep = Tup4Type typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        )

    toTarget n (a,b,c,d) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        )

instance (Type a, Type b, Type c, Type d, Type e) => Type (a,b,c,d,e)
  where
    typeRep = Tup5Type typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        )

    toTarget n (a,b,c,d,e) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f) => Type (a,b,c,d,e,f)
  where
    typeRep = Tup6Type typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        )

    toTarget n (a,b,c,d,e,f) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g) => Type (a,b,c,d,e,f,g)
  where
    typeRep = Tup7Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        )

    toTarget n (a,b,c,d,e,f,g) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h) => Type (a,b,c,d,e,f,g,h)
  where
    typeRep = Tup8Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        )

    toTarget n (a,b,c,d,e,f,g,h) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i) => Type (a,b,c,d,e,f,g,h,i)
  where
    typeRep = Tup9Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        )

    toTarget n (a,b,c,d,e,f,g,h,i) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j) => Type (a,b,c,d,e,f,g,h,i,j)
  where
    typeRep = Tup10Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k) => Type (a,b,c,d,e,f,g,h,i,j,k)
  where
    typeRep = Tup11Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k, Type l) => Type (a,b,c,d,e,f,g,h,i,j,k,l)
  where
    typeRep = Tup12Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k,l) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        , sizeOf l
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k,l) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        , toTarget n l
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k, Type l, Type m) => Type (a,b,c,d,e,f,g,h,i,j,k,l,m)
  where
    typeRep = Tup13Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k,l,m) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        , sizeOf l
        , sizeOf m
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k,l,m) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        , toTarget n l
        , toTarget n m
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k, Type l, Type m,Type n') => Type (a,b,c,d,e,f,g,h,i,j,k,l,m,n')
  where
    typeRep = Tup14Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k,l,m,n') =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        , sizeOf l
        , sizeOf m
        , sizeOf n'
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k,l,m,n') =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        , toTarget n l
        , toTarget n m
        , toTarget n n'
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g, Type h, Type i, Type j, Type k, Type l, Type m, Type n', Type o) => Type (a,b,c,d,e,f,g,h,i,j,k,l,m,n',o)
  where
    typeRep = Tup15Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g,h,i,j,k,l,m,n',o) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        , sizeOf h
        , sizeOf i
        , sizeOf j
        , sizeOf k
        , sizeOf l
        , sizeOf m
        , sizeOf n'
        , sizeOf o
        )

    toTarget n (a,b,c,d,e,f,g,h,i,j,k,l,m,n',o) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        , toTarget n h
        , toTarget n i
        , toTarget n j
        , toTarget n k
        , toTarget n l
        , toTarget n m
        , toTarget n n'
        , toTarget n o
        )

instance (Type a, Show (IORef a)) => Type (IORef a)
  where
    typeRep = RefType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: IORef"  -- TODO Requires IO

instance Type a => Type (MArr a)
  where
    typeRep = MArrType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: MArr"  -- TODO Requires IO

instance Type a => Type (Elements a)
  where
    typeRep = ElementsType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: Elements"  -- TODO Requires IO

instance (Type a, Type (RTuple a), Eq (Tuple a), Size (Tuple a) ~ Size (RTuple a))
  => Type (Tuple a)
  where
    typeRep = TupleType typeRep

    sizeOf (Tuple xs) = sizeOf xs

    toTarget = error "toTarget: Tuple"

instance Type a => Type (IV a)
  where
    typeRep = IVarType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: IVar" -- TODO Requires IO

instance Type a => Type (FVal a)
  where
    typeRep = FValType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: FVal" -- TODO

-- | Extend the class Type to higher order types
class (Typeable a, Show (Size a), Lattice (Size a)) => TypeF a where
  typeRepF :: TypeRep a
  sizeOfF :: a -> Size a

instance {-# OVERLAPPING #-} (TypeF a, TypeF b) => TypeF (a -> b) where
  typeRepF = FunType typeRepF typeRepF
  sizeOfF f = universal

instance {-# OVERLAPPING #-} (Type a, Typeable b, TypeF (RTuple b)) => TypeF (RTuple (a :* b))
  where
    typeRepF = ConsType typeRep typeRepF
    sizeOfF (x :* xs) = (sizeOf x, sizeOfF xs)

instance {-# OVERLAPPING #-} TypeF (RTuple TNil)
  where
    typeRepF = NilType
    sizeOfF _ = universal

instance {-# OVERLAPPABLE #-} (Typeable a, Type a) => TypeF a where
  typeRepF = typeRep
  sizeOfF = sizeOf

--------------------------------------------------------------------------------
-- * Sized types
--------------------------------------------------------------------------------

data AnySize = AnySize
    deriving (Eq, Show, Ord)

anySizeFun :: AnySize -> AnySize
anySizeFun AnySize = AnySize

anySizeFun2 :: AnySize -> AnySize -> AnySize
anySizeFun2 AnySize AnySize = AnySize

instance Num AnySize
  where
    fromInteger _ = AnySize
    abs           = anySizeFun
    signum        = anySizeFun
    (+)           = anySizeFun2
    (-)           = anySizeFun2
    (*)           = anySizeFun2

instance Lattice AnySize
  where
    bot  = AnySize
    top  = AnySize
    (\/) = anySizeFun2
    (/\) = anySizeFun2

type family Size a where
  Size ()              = AnySize
  Size Bool            = AnySize
  Size Word8           = Range Word8
  Size Int8            = Range Int8
  Size Word16          = Range Word16
  Size Int16           = Range Int16
  Size Word32          = Range Word32
  Size Int32           = Range Int32
  Size Word64          = Range Word64
  Size Int64           = Range Int64
  Size WordN           = Range WordN
  Size IntN            = Range IntN
  Size Float           = AnySize
  Size Double          = AnySize
  Size (Complex a)     = AnySize
  Size [a]             = Range Length :> Size a
  Size (TargetArr n a) = Range (GenericInt U n) :> Size a
  Size (a,b)           = (Size a, Size b)
  Size (a,b,c)         = (Size a, Size b, Size c)
  Size (a,b,c,d)       = (Size a, Size b, Size c, Size d)
  Size (a,b,c,d,e)     = (Size a, Size b, Size c, Size d, Size e)
  Size (a,b,c,d,e,f)   = (Size a, Size b, Size c, Size d, Size e, Size f)
  Size (a,b,c,d,e,f,g) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g)
  Size (a,b,c,d,e,f,g,h) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h)
  Size (a,b,c,d,e,f,g,h,i) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i)
  Size (a,b,c,d,e,f,g,h,i,j) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j)
  Size (a,b,c,d,e,f,g,h,i,j,k) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k)
  Size (a,b,c,d,e,f,g,h,i,j,k,l) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k, Size l)
  Size (a,b,c,d,e,f,g,h,i,j,k,l,m) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k, Size l, Size m)
  Size (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k, Size l, Size m, Size n)
  Size (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g, Size h, Size i, Size j, Size k, Size l, Size m, Size n, Size o)
  Size (a -> b)        = (Size a, Size b)
  Size (Mut a)         = Size a
  Size (IORef a)       = Size a
  Size (MArr a)        = Range Length :> Size a
  Size (Par a)         = Size a
  Size (Elements a)    = Range Length :> Size a
  Size (RTuple (a :* b)) = (Size a, Size (RTuple b))
  Size (RTuple TNil)   = Size ()
  Size (Tuple a)       = Size (RTuple a)
  Size (IV a)          = Size a
  Size (FVal a)        = Size a

tIntN :: Patch IntN IntN
tIntN = id

tWordN :: Patch WordN WordN
tWordN = id

tIndex :: Patch Index Index
tIndex  = id

tLength :: Patch Length Length
tLength = id

tArr :: Patch a a -> Patch [a] [a]
tArr _ = id


{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}

module School.FileIO.Test.Source
( sourceTest ) where

import Conduit ((.|), ConduitM, MonadResource, runConduit, sinkList, yield)
import Control.Monad.Except (MonadError)
import Data.ByteString (ByteString)
import Data.ByteString.Conversion (toByteString')
import Data.Either (isLeft, isRight)
import Data.Monoid ((<>))
import School.FileIO.AppIO (AppIO, runAppIO)
import School.FileIO.ConduitHeader (conduitHeader)
import School.FileIO.FileHeader (FileHeader(..))
import School.FileIO.Source
import School.TestUtils (def, dummyList, dummyMatrix)
import School.Types.Decoding (binToMatrixDouble)
import School.Types.Encoding (doubleToBin)
import School.Types.Error (Error)
import School.Types.DataType (DataType(..), getSize)
import School.Types.LiftResult (LiftResult(..))
import Numeric.LinearAlgebra.Data (Matrix)
import Test.Tasty (TestTree)
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Test.QuickCheck.Monadic (PropertyM, assert, monadicIO, pre, run)

matrixDoubleSource :: (LiftResult m, MonadError Error m, MonadResource m)
                   => FileHeader
                   -> FilePath
                   -> ConduitM () (Matrix Double) m ()
matrixDoubleSource = source

testHeader :: FileHeader
           -> ByteString
           -> PropertyM IO (Either String [ByteString])
testHeader header byteString = run . runAppIO . runConduit $
  yield byteString .| conduitHeader header .| sinkList

poolMatrixDouble :: Positive Int
                 -> Positive Int
                 -> ConduitM ByteString (Matrix Double) AppIO ()
poolMatrixDouble (Positive r) (Positive c) =
  let trans = liftResult . binToMatrixDouble DBL64B r c
      size = getSize DBL64B
  in pool (r * c * size) trans

testMatrix :: Positive Int
           -> Positive Int
           -> ByteString
           -> PropertyM IO (Either String [Matrix Double])

testMatrix pr pc bytes = run . runAppIO . runConduit $
    yield bytes
 .| poolMatrixDouble pr pc
 .| sinkList

prop_accepts_header :: DataType -> Positive Int -> Property
prop_accepts_header name (Positive n) =
  monadicIO $ do
    let h = FileHeader name n n
    result <- testHeader h (toByteString' h)
    assert $ isRight result

prop_preserves_rest :: String -> Property
prop_preserves_rest content =
  monadicIO $ do
    pre $ content /= ""
    let h = def
    let bContent = toByteString' content
    let bytes = toByteString' h <> bContent
    result <- testHeader h bytes
    assert $ result == Right [bContent]

prop_rejects_wrong_separator :: Char -> String -> Property
prop_rejects_wrong_separator separator content =
  monadicIO $ do
    pre $ separator /= '#'
    let bytes = toByteString' separator <> toByteString' content
    result <- testHeader def bytes
    assert $ isLeft result

prop_rejects_wrong_header :: DataType
                          -> DataType
                          -> Positive Int
                          -> Positive Int
                          -> Positive Int
                          -> Positive Int
                          -> Property
prop_rejects_wrong_header name1
                          name2
                          (Positive n1)
                          (Positive n2)
                          (Positive n3)
                          (Positive n4) =
  monadicIO $ do
    pre $ name1 /= name2
       || mod n3 n1 /= 0
       || n2 /= n4
    let h1 = FileHeader name1 n1 n2
    let h2 = FileHeader name2 n3 n4
    result <- testHeader h1 (toByteString' h2)
    assert $ isLeft result

encodeDoubles :: [Double] -> ByteString
encodeDoubles = foldMap doubleToBin

prop_read_double_matrix :: Positive Int
                      -> Positive Int
                      -> Property
prop_read_double_matrix pr@(Positive r) pc@(Positive c) =
  monadicIO $ do
    let bytes = encodeDoubles $ dummyList r c
    matrix <- testMatrix pr pc bytes
    assert $ matrix == Right [dummyMatrix r c]

prop_read_two_double_matrices :: Positive Int
                           -> Positive Int
                           -> Property
prop_read_two_double_matrices pr@(Positive r) pc@(Positive c) =
  monadicIO $ do
    let list = dummyList r c
    let bytes = encodeDoubles $ list <> list
    matrices <- testMatrix pr pc bytes
    let check = dummyMatrix r c
    assert $ matrices == Right [check, check]

prop_read_with_extra :: Positive Int
                   -> Positive Int
                   -> Property
prop_read_with_extra pr@(Positive r) pc@(Positive c) =
  monadicIO $ do
    pre $ c > 1
    let extra = encodeDoubles [3]
    let bytes = encodeDoubles $ dummyList r c
    matrix <- testMatrix pr pc (bytes <> extra)
    assert $ isLeft matrix

prop_read_3x3_matrix :: Property
prop_read_3x3_matrix = monadicIO $ do
  let h = FileHeader DBL64B 3 3
  let path = "test/data/matrix3x3.sm"
  stack <- run . runAppIO . runConduit $
    matrixDoubleSource h path .| sinkList
  assert $ stack == Right [dummyMatrix 3 3]

prop_read_3x3_matrix_twice :: Property
prop_read_3x3_matrix_twice = monadicIO $ do
  let h = FileHeader DBL64B 3 3
  let path = "test/data/matrix3x3Twice.sm"
  stack <- run . runAppIO . runConduit $
    matrixDoubleSource h path .| sinkList
  let mat = dummyMatrix 3 3
  assert $ stack == Right [mat, mat]

sourceTest :: TestTree
sourceTest = $(testGroupGenerator)