{-# OPTIONS -fglasgow-exts #-}

{-
    Abstract syntax tree.

    Tall ships and tall kings
    Three times three.
    What brought they from the foundered land
    Over the flowing sea?
    Seven stars and seven stones
    And one white tree.
-}

module AST where
import Internals

type Ident = String

instance Show (a -> b) where
    show f = "sub { ... }"

class Context n where
    vCast :: Val -> n
    vCast (VRef v)      = vCast v
    vCast (VPair _ v)   = vCast v
    vCast v             = doCast v
    doCast :: Val -> n
    doCast v = error $ "cannot cast: " ++ (show v)

instance Context VBool where
    doCast (VJunc j l) = juncToBool j l
    doCast (VBool b)   = b
    doCast VUndef      = False
    doCast (VStr "")   = False
    doCast (VStr "0")  = False
    doCast (VInt 0)    = False
    doCast (VRat 0)    = False
    doCast (VNum 0)    = False
    doCast (VList [])  = False
    doCast _           = True

juncToBool :: JuncType -> [Val] -> Bool
juncToBool JAny     = any vCast
juncToBool JAll     = all vCast
juncToBool JNone    = all (not . vCast)
juncToBool JOne     = (1 ==) . length . filter vCast

instance Context VInt where
    doCast (VInt i)     = i
    doCast (VStr s)
        | ((n, _):_) <- reads s = n
        | otherwise             = 0
    doCast x            = round (vCast x :: VNum)

instance Context VRat where
    doCast (VInt i)     = i % 1
    doCast (VRat r)     = r
    doCast x            = approxRational (vCast x :: VNum) 1

instance Context VNum where
    doCast VUndef       = 0
    doCast (VBool b)    = if b then 1 else 0
    doCast (VInt i)     = fromIntegral i
    doCast (VRat r)     = realToFrac r
    doCast (VNum n)     = n
    doCast (VStr s)
        | ((n, _):_) <- reads s = n
        | otherwise             = 0
    doCast (VList l)    = fromIntegral $ length l
    doCast x            = error $ "cannot cast: " ++ (show x)

instance Context VComplex where
    doCast x            = (vCast x :: VNum) :+ 0

instance Context VStr where
    vCast VUndef        = ""
    vCast (VStr s)      = s
    vCast (VBool b)     = if b then "1" else "0"
    vCast (VInt i)      = show i
    vCast (VRat r)      = showNum $ realToFrac r
    vCast (VNum n)      = showNum n
    vCast (VList l)     = unwords $ map vCast l
    vCast (VRef v)      = vCast v
    vCast (VPair k v)   = vCast k ++ "\t" ++ vCast v ++ "\n"
    doCast x            = error $ "cannot cast: " ++ (show x)

showNum x
    | (i, ".0") <- break (== '.') str
    = i -- strip the trailing ".0"
    | otherwise = str
    where
    str = show x 

instance Context VList where
    vCast (VList l)     = l
    vCast (VPair k v)   = [k, v]
    vCast (VRef v)      = vCast v
    vCast v             = [v]

instance Context (Maybe a) where
    vCast VUndef        = Nothing
    vCast _             = Just undefined

instance Context Int   where doCast = intCast
instance Context Word  where doCast = intCast
instance Context Word8 where doCast = intCast
instance Context [Word8] where doCast = map (toEnum . ord) . vCast

type VScalar = Val

instance Context VScalar where
    vCast x             = x

strRangeInf s = (s:strRangeInf (strInc s))

strRange s1 s2
    | s1 == s2              = [s2]
    | length s1 > length s2 = []
    | otherwise             = (s1:strRange (strInc s1) s2)

strInc []       = "1"
strInc "z"      = "aa"
strInc "Z"      = "AA"
strInc "9"      = "10"
strInc str
    | x == 'z'  = strInc xs ++ "a"
    | x == 'Z'  = strInc xs ++ "A"
    | x == '9'  = strInc xs ++ "0"
    | otherwise = xs ++ [charInc x]
    where
    x   = last str
    xs  = init str

charInc x   = chr $ 1 + ord x

intCast x   = fromIntegral (vCast x :: VInt)

type VBool = Bool
type VInt  = Integer
type VRat  = Rational
type VNum  = Double
type VComplex = Complex VNum
type VStr  = String
type VList = [Val]
newtype VArray = MkArray [Val] deriving (Show, Eq, Ord)
newtype VHash  = MkHash (FiniteMap Val Val) deriving (Show, Eq, Ord)

instance (Show a, Show b) => Show (FiniteMap a b) where
    show fm = show (fmToList fm)

instance (Ord a, Ord b) => Ord (FiniteMap a b) where

instance Ord VComplex where
    {- ... -}

data Val
    = VUndef
    | VBool     VBool
    | VInt      VInt
    | VRat      VRat
    | VNum      VNum
    | VComplex  VComplex
    | VStr      VStr
    | VList     VList
    | VArray    VArray
    | VHash     VHash
    | VRef      Val
    | VPair     Val Val
    | VSub      Exp
    | VBlock    Exp
    | VJunc     JuncType [Val]
    | VError    VStr Exp
    | VPoly     { polyScalar    :: Val
                , polyList      :: Val
                }
    deriving (Show, Eq, Ord)

data Trait
    = TScalar   Val
    | TArray    Val
    | THash     Val

data JuncType = JAll | JAny | JOne | JNone
    deriving (Show, Eq, Ord)

data Exp
    = Op1 String Exp
    | Op2 String Exp Exp
    | Op3 String Exp Exp Exp
    | OpCmp String Exp Exp
    | Val Val
    | NonTerm SourcePos
    deriving (Show, Eq, Ord)