ast.hs

module Ast where
import Data.Map as Map
import Data.List as List
import Data.Maybe as Maybe
import Data.Word as Word
import Text.Parsec.Pos (SourcePos, initialPos)

dummy_pos = initialPos "compiler generated"

class HasPos a where
  getPos :: a -> SourcePos

data Lit = 
    IntLit Integer
  | Char Char
  | StrLit String
  | Word8 Word8
  deriving Eq

instance Show Lit where
  show (IntLit i) = 
    if i >= 0 then
      show i
    else
      '~' : show (-i)
  show (Char c) = "#\"" ++ show c ++ "\""  -- TODO Cake-ify
  show (StrLit s) = "\"" ++ show s ++ "\"" -- TODO Cakeify
  show (Word8 w) = show w  -- TODO Cakeify

data Opn = Plus | Minus | Times | Divide | Modulo
  deriving Eq

data Opb = Lt | Gt | Leq | Geq

data ModN = ModN String SourcePos

instance HasPos ModN where
  getPos (ModN _ p) = p

instance Eq ModN where
  (==) (ModN x _) (ModN y _) = x == y

instance Ord ModN where
  compare (ModN x _) (ModN y _) = compare x y

instance Show ModN where
  show (ModN x _) = x

data Id a = Short a
          | Long ModN a
  deriving (Eq, Ord)

instance HasPos a => HasPos (Id a) where
  getPos (Long m a) = getPos a
  getPos (Short a) = getPos a

instance Show a => Show (Id a) where
  show (Short x) = show x
  show (Long x y) = show x ++ "." ++ show y

data VarN = VarN String SourcePos

instance HasPos VarN where
  getPos (VarN _ p) = p

instance Eq VarN where
  (==) (VarN x _) (VarN y _) = x == y

instance Ord VarN where
  compare (VarN x _) (VarN y _) = compare x y

instance Show VarN where
  show (VarN x _) = x

data ConN = ConN String SourcePos

instance HasPos ConN where
  getPos (ConN _ p) = p

instance Eq ConN where
  (==) (ConN x _) (ConN y _) = x == y

instance Ord ConN where
  compare (ConN x _) (ConN y _) = compare x y

instance Show ConN where
  show (ConN x _) = x

data TypeN = TypeN String SourcePos

instance Eq TypeN where
  (==) (TypeN x _) (TypeN y _) = x == y

instance Ord TypeN where
  compare (TypeN x _) (TypeN y _) = compare x y

instance Show TypeN where
  show (TypeN x _) = x

instance HasPos TypeN where
  getPos (TypeN _ p) = p

data TvarN = TvarN String SourcePos

instance HasPos TvarN where
  getPos (TvarN _ p) = p

instance Eq TvarN where
  (==) (TvarN x _) (TvarN y _) = x == y

instance Ord TvarN where
  compare (TvarN x _) (TvarN y _) = compare x y

instance Show TvarN where
  show (TvarN x _) = x

mk_id :: Maybe ModN -> a -> Id a
mk_id Nothing n = Short n
mk_id (Just mn) n = Long mn n

id_to_n :: Id a -> a
id_to_n (Short n) = n
id_to_n (Long _ n) = n

data Op = 
  -- Operations on integers
    Opn Opn SourcePos
  | Opb Opb SourcePos
  -- Polymorphic =
  | Equality SourcePos
  -- Application
  | Opapp
  -- Reference operations
  | Opassign SourcePos
  | Opref SourcePos
  | Opderef SourcePos
  -- Word8Array operations
  | Aw8alloc SourcePos
  | Aw8sub SourcePos
  | Aw8length SourcePos
  | Aw8update SourcePos
  -- Char operations
  | Ord SourcePos
  | Chr SourcePos
  | Chopb Opb SourcePos
  -- String operations
  | Explode SourcePos
  | Implode SourcePos
  | Strlen SourcePos
  -- Vector operations
  | VfromList SourcePos
  | Vsub SourcePos
  | Vlength SourcePos
  -- Array operations
  | Aalloc SourcePos
  | Asub SourcePos
  | Alength SourcePos
  | Aupdate SourcePos
  -- Call a given foreign function
  | FFI Integer SourcePos

data Lop = And SourcePos | Or SourcePos

instance HasPos Lop where
  getPos (And p) = p
  getPos (Or p) = p

data Tc = 
    TC_name (Id TypeN)
  | TC_int
  | TC_char
  | TC_string
  | TC_ref
  | TC_word8
  | TC_word8array
  | TC_fn
  | TC_tup
  | TC_exn
  | TC_vector
  | TC_array
  deriving Eq

instance Show Tc where
  show (TC_name n) = show n
  show TC_int = "int"
  show TC_char = "char"
  show TC_string = "string"
  show TC_ref = "ref"
  show TC_word8 = "Word8.t"
  show TC_word8array = "Word8Array.t"
  show TC_fn = "->"
  show TC_tup = "*"
  show TC_exn = "exn"
  show TC_vector = "Vector.t"
  show TC_array = "Array.t"

data T = 
    Tvar TvarN
  | Tvar_db Integer
  | Tapp [T] Tc
  deriving Eq

instance Show T where
  show (Tvar tv) = show tv
  show (Tvar_db n) = show n
  show (Tapp ts tc) = show ts ++ show tc

tint = Tapp [] TC_int
tchar = Tapp [] TC_char
tstring = Tapp [] TC_string
tref t = Tapp [t] TC_ref
tword8 = Tapp [] TC_word8
tword8array = Tapp [] TC_word8array
tfn t1 t2 = Tapp [t1,t2] TC_fn
texn = Tapp [] TC_exn

data Pat = 
    Pvar VarN
  | Plit Lit SourcePos
  | Pcon (Maybe (Id ConN)) [Pat] SourcePos
  | Pref Pat SourcePos

data Exp = 
    Raise Exp
  | Handle Exp [(Pat,Exp)]
  | Lit Lit SourcePos
  | Con (Maybe (Id ConN)) [Exp] SourcePos
  | Var (Id VarN)
  | Fun VarN Exp SourcePos
  | App Op [Exp]
  | Log Lop Exp Exp
  | If Exp Exp Exp
  | Mat Exp [(Pat,Exp)]
  | Let (Maybe VarN) Exp Exp
  | Letrec [(VarN,VarN,Exp)] Exp

type Type_def = [([TvarN], TypeN, [(ConN, [T])])]

data Dec = 
    Dlet Pat Exp SourcePos
  | Dletrec [(VarN, VarN, Exp)]
  | Dtype Type_def
  | Dtabbrev [TvarN] TypeN T
  | Dexn ConN [T]

type Decs = [Dec]

data Spec = 
    Sval VarN T
  | Stype Type_def
  | Stabbrev [TvarN] TypeN T
  | Stype_opq [TvarN] TypeN
  | Sexn ConN [T]

type Specs = [Spec]

data Top = 
    Tmod ModN (Maybe Specs) Decs
  | Tdec Dec

type Prog = [Top]

pat_bindings :: Pat -> [VarN] -> [VarN]
pat_bindings (Pvar n) already_bound = n:already_bound
pat_bindings (Plit l _) already_bound = already_bound
pat_bindings (Pcon _ ps _) already_bound = pats_bindings ps already_bound
pat_bindings (Pref p _) already_bound = pat_bindings p already_bound
pats_bindings [] already_bound = already_bound
pats_bindings (p:ps) already_bound = pats_bindings ps (pat_bindings p already_bound)


{- Old stuff 

newtype Env k v = Env (Map k v)

emp :: Env k v
emp = Env Map.empty

merge :: Ord k => Env k v -> Env k v -> Env k v
merge (Env m1) (Env m2) = Env (Map.union m1 m2)

bind :: Ord k => k -> v -> Env k v -> Env k v
bind k v (Env m) = Env (Map.insert k v m)

listToEnv :: Ord k => [(k,v)] -> Env k v
listToEnv l = Env (Map.fromList l)

envToList :: Env k v -> [(k,v)]
envToList (Env m) = Map.assocs m

envAll :: (k -> v -> Bool) -> Env k v -> Bool
envAll f (Env m) = List.all (\(x,y) -> f x y) (Map.assocs m)

envElem :: Ord k => k -> Env k v -> Bool
envElem k (Env m) = Map.member k m

show_pair (x,y) = "val " ++ show x ++ " = " ++ show y ++ ";"

instance (Show k, Show v) => Show (Env k v) where
  show (Env e) = List.intercalate "\n" (List.map show_pair (Map.assocs e))

opn_lookup :: Opn -> Integer -> Integer -> Integer
opn_lookup Plus = (+)
opn_lookup Minus = (-)
opn_lookup Times = ( * )
opn_lookup Divide = (div)
opn_lookup Modulo = (mod)

opb_lookup :: Opb -> Integer -> Integer -> Bool
opb_lookup Lt = (<)
opb_lookup Gt = (>)
opb_lookup Leq = (<=)
opb_lookup Geq = (>=)


data Tid_or_exn = 
    TypeId (Id TypeN)
  | TypeExn

instance Eq Tid_or_exn where
  (==) TypeExn TypeExn = True
  (==) (TypeId tid1) (TypeId tid2) = tid1 == tid2
  (==) _ _ = False



-}