casui-0.3: Casui/Value.hs

module Casui.Value where

import Casui.Name

import Data.Ratio
import Data.List

data Value val = VName Name
               | VExact Rational
               | VString String
               | VList [val]
               | VStruct FullName [val]
               | VFun ([val] -> val)
               -- | VProc ([val] -> Casui val)

data Property name val = E name [val]

data Expression = Expression {
  eProperties :: Property FullName Expression,
  eValue :: Value Expression
  }

type Type = FullName

class Val v where
  val :: v -> Value v

class ToValue a where
  value :: a -> Value v

class FromValue a where
  unvalue :: Value v -> Maybe a

instance ToValue Bool where
  value True = VName $ fullName Builtin "bool:true"
  value False = VName $ fullName Builtin "bool:false"

instance FromValue Bool where
  unvalue (VName n) | n == builtin "bool:true" = Just True
                      | n == builtin "bool:false" = Just False
  unvalue _ = Nothing

instance ToValue Int where
  value = VExact . toRational
  
instance FromValue Int where
  unvalue (VExact r) = if denominator r == 1 then Just . fromInteger $ numerator r else Nothing
  unvalue _ = Nothing

baseType :: Value v -> Type
baseType (VName _) = builtin "type:symbol"
baseType (VExact _) = builtin "type:rational"
baseType (VString _) = builtin "type:string"
baseType (VList _) = builtin "type:list"
baseType (VFun _) = builtin "type:fun"
baseType (VStruct t _) = t


isPrimitiveType :: FName n => n -> Bool
isPrimitiveType (show -> s) = elem s . map ("builtin:type:"++) $ ["symbol", "rational", "string"]

                                         
instance Show v => Show (Value v) where
  show (VName n) = show n
  show (VExact r) = if denominator r == 1 then show $ numerator r else show $ (fromRational r :: Double)
  show (VString s) = show s
  show (VList l) = "(" ++ (concat . intersperse " ") (map show l) ++ ")"
  show (VFun _) = "#fun"
  show (VStruct n [a]) | show n == "builtin:script:quote" = "'" ++ show a
  show (VStruct n [a]) | show n == "builtin:script:unquote" = "," ++ show a
  show (VStruct n [a]) | show n == "builtin:script:quasiquote" = "`" ++ show a
  show (VStruct n l) = "(" ++ (concat . intersperse " ") (show n : map show l) ++ ")"