{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

module Language.CalDims.Types 
	( Name (..)
	, MyParser
	, Scope
	, State (..)
	, StateEntry (..)
	, D
	, R
	, Conversion (..)
	, Expr (..)
	, BinOp (..)
	, UniOp (..)
	, Priority (..)
	, Args
	, Arg (..)
	, Pretty (..)
	, Dims (..)
	, noDims
	, EqM (..)
	, AddM (..)
	, SubM (..)
	, MulM (..)
	, DivM (..)
	, ExpM (..)
	, LogBaseM (..)
	, NegateM (..)
	, ExpotM (..)
	, LogM (..)
	, SqrtM (..)
	, SinM (..)
	, CosM (..)
	, TanM (..)
	, AsinM (..)
	, AcosM (..)
	, AtanM (..)
	, SinhM (..)
	, CoshM (..)
	, TanhM (..)
	, AsinhM (..)
	, AcoshM (..)
	, AtanhM (..)) where


import Text.ParserCombinators.Parsec (GenParser)
import qualified Data.Map as Map
import Data.Ratio
--import Data.Generics
import Control.Monad.Error
import qualified Data.List as List
class Pretty a where
	pretty :: a -> String

instance Pretty Int where pretty i = show i
instance Pretty a => Pretty [a] where
	pretty [] = "[]"
	pretty (a:l) = "[" ++ foldl (\x y -> x ++ ", " ++ y) (pretty a) (map pretty l) ++ "]"

instance Pretty Char where pretty c = [c]


instance Pretty Dims where
        pretty (Dims a)
                | null list = ""
                | otherwise = tail (pretty' list)
                where
                        list = filter (\ (_, y) -> y /= 0) $ List.sort $ Map.toList a

                        pretty' :: [(Name, R)] -> String
                        pretty' [] = ""
                        pretty' (el@(_, exp_):fs) = if exp_ > 0
                                then ePretty el ++ pretty' fs
                                else pretty' fs ++ " /" ++ ePretty el

                        ePretty :: (Name, R) -> String
                        ePretty (name, e) = let n = pretty name in
                                " " ++ if abs e == 1 then n else n ++ "^" ++ (pretty $ abs e)



data Conversion = Explicit Dims | InTermsOf Expr | Basic | Keep | Minimal deriving Show

type D = Double
type R = Ratio Integer

newtype Name = Name {unName :: String} deriving (Eq, Show, Ord)
instance Pretty Name where pretty (Name s) = s

instance Pretty (Ratio Integer) where
        pretty r = if d == 1 then (show n) else show . floating $ r where
                d = denominator r
                n = numerator r

floating :: R -> D
floating r = fromInteger (numerator r) / fromInteger (denominator r)


type MyParser = GenParser Char State

type Scope = Map.Map Name StateEntry

data State = State
        { getScope :: Scope
        , getArgs :: Args
        , getArgValues :: [(R, Dims)]
        } deriving (Show)

data StateEntry = Function Args Expr | Dimension Expr | BasicDimension | Builtin Args Expr
        deriving (Show)


data Expr = Bin BinOp Expr Expr | Uni UniOp Expr | ArgRef Arg
        | Call Name [Expr] | Evaled (R, Dims) deriving (Show)

data BinOp = Add | Sub | Mul | Div | Exp | LogBase
        deriving (Eq, Show)

data UniOp = Negate | Expot | Log | Sin | Cos | Tan | Asin | Acos | Atan
        | Sinh | Cosh | Tanh | Asinh | Acosh | Atanh
        deriving (Eq, Show)

data Priority = P_Add |  P_Mul |  P_Exp | P_Negate | P_Elementary
        deriving (Eq, Enum, Ord)

type Args = [Arg]

data Arg = Arg
        { getArgName :: String -- This is not a Name because it does not reference a State-Entry.
        , getArgNumber :: Int
        , getArgType :: Dims
        } deriving (Show, Ord, Eq)

newtype Dims = Dims {unDims :: Map.Map Name R} deriving (Show, Ord, Eq)

noDims :: Dims
noDims  = Dims Map.empty


class (Monad m) => EqM a m where (#==#) :: m a -> m a -> m Bool

class (Monad m) => AddM a m where (#+#) :: m a -> m a -> m a
class (Monad m) => SubM a m where (#-#) :: m a -> m a -> m a
class (Monad m) => MulM a m where (#*#) :: m a -> m a -> m a
class (Monad m) => DivM a m where (#/#) :: m a -> m a -> m a
class (Monad m) => ExpM a m where (#^#) :: m a -> m a -> m a
class (Monad m) => LogBaseM a m where (#~#) :: m a -> m a -> m a

class (Monad m) => NegateM a m where negateM :: m a -> m a
class (Monad m) => ExpotM a m where expM :: m a -> m a
class (Monad m) => LogM a m where logM :: m a -> m a
class (Monad m) => SqrtM a m where sqrtM :: m a -> m a
class (Monad m) => SinM a m where sinM :: m a -> m a
class (Monad m) => CosM a m where cosM :: m a -> m a
class (Monad m) => TanM a m where tanM :: m a -> m a
class (Monad m) => AsinM a m where asinM :: m a -> m a
class (Monad m) => AcosM a m where acosM :: m a -> m a
class (Monad m) => AtanM a m where atanM :: m a -> m a
class (Monad m) => SinhM a m where sinhM :: m a -> m a
class (Monad m) => CoshM a m where coshM :: m a -> m a
class (Monad m) => TanhM a m where tanhM :: m a -> m a
class (Monad m) => AsinhM a m where asinhM :: m a -> m a
class (Monad m) => AcoshM a m where acoshM :: m a -> m a
class (Monad m) => AtanhM a m where atanhM :: m a -> m a