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