tempus-0.1.0: Tempus/Syntax.hs

{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}

-- | Tempus abstract syntax tree types.
module Tempus.Syntax (
    Program,
    Decl (..),
    Type (..),
    MuType (..),
    NuType (..),
    Expr (..),
    Var (..),

    SrcCode (..)
) where

import Data.Data
import Data.Generics.Uniplate.Data ()
import Data.List

import Tempus.Loc


-- | A Tempus program as a list of definitions.
type Program = [Decl]

-- | A Tempus type or value definition.
data Decl = DeclType SrcLoc Var [Var] Type
          | DeclVal SrcLoc Var Expr
          deriving (Eq, Show)


-- | A Tempus type.
data Type = TyMu MuType
          | TyNu NuType
          | TyFun Type Type
          | TyPlus Type Type
          | TyPair Type Type
          | TyApp Var [Type]
          | TyBehav Type
          | TyEvent Type
          | TyNat
          | TyZero
          | TyUnit

          -- only used for type checking
          | TyVar Integer
          | TyCon Integer
          deriving (Eq, Show, Data, Typeable)


-- | A mu type.
data MuType = MuType Var Type
            deriving (Eq, Show, Data, Typeable)


-- | A nu type.
data NuType = NuType Var Type
            deriving (Eq, Show, Data, Typeable)


-- | A Tempus expression.
data Expr = ExPair Expr Expr
          | ExLam Var Expr
          | ExLiftAppB Expr Expr
          | ExLiftAppE Expr Expr
          | ExApp Expr Expr
          | ExConst Expr
          | ExVar Var
          | ExNatLit Integer
          | ExBehav Expr
          | ExEvent Expr Expr
          | ExNull
          | ExUnit
          | ExLeft
          | ExRight
          | ExCase
          | ExExpand
          | ExFst
          | ExSnd
          | ExNever
          | ExRace
          | ExReflect
          | ExFold Type Expr
          | ExUnfold Type Expr
          | ExPack Type
          | ExUnpack Type
          | ExUJump
          | ExUSwitch
          deriving (Eq, Show, Data, Typeable)


-- | A variable.
newtype Var = Var String deriving (Eq, Show, Data, Typeable)


-- | Wrapper for displaying values as source code.
newtype SrcCode a = SrcCode a

instance Show (SrcCode Decl) where
    showsPrec _ (SrcCode (DeclType _ v vs t)) = 
        showString "type " . showsVars (map SrcCode (v:vs)) . showString " = " . shows (SrcCode t)
    showsPrec _ (SrcCode (DeclVal _ v e)) = 
        showString "value " . shows (SrcCode v) . showString " = " . shows (SrcCode e)

showsVars :: [SrcCode Var] -> ShowS
showsVars []     = id
showsVars [v]    = shows v
showsVars (v:vs) = shows v . showChar ' ' . showsVars vs

instance Show (SrcCode Expr) where
    showsPrec p (SrcCode (ExPair e1 e2)) = showParen (p > 0) $
        showsPrec 1 (SrcCode e1) . showString " , " . showsPrec 0 (SrcCode e2)
    showsPrec p (SrcCode (ExLam v e)) = showParen (p > 1) $
        showString "\\ " . shows (SrcCode v) . showString " . " . showsPrec 1 (SrcCode e)
    showsPrec p (SrcCode (ExLiftAppB e1 e2)) = showParen (p > 2) $
        showsPrec 2 (SrcCode e1) . showString " <*> " . showsPrec 3 (SrcCode e2)
    showsPrec p (SrcCode (ExLiftAppE e1 e2)) = showParen (p > 2) $
        showsPrec 2 (SrcCode e1) . showString " <.> " . showsPrec 3 (SrcCode e2)
    showsPrec p (SrcCode (ExApp e1 e2)) = showParen (p > 3) $
        showsPrec 3 (SrcCode e1) . showChar ' ' . showsPrec 4 (SrcCode e2)
    showsPrec p (SrcCode (ExConst e)) = showParen (p > 3) $
        showString "const " . showsPrec 4 (SrcCode e)
    showsPrec p (SrcCode (ExBehav f)) = showParen (p > 3) $
        showString "behavior " . showsPrec 4 (SrcCode f)
    showsPrec p (SrcCode (ExEvent t e)) = showParen (p > 3) $
        showString "event " . showsPrec 4 (SrcCode t) . showChar ' ' . showsPrec 4 (SrcCode e)
    showsPrec p (SrcCode (ExFold t f)) = showParen (p > 3) $
        showString "fold [" . shows (SrcCode t) . showString "] " . showsPrec 4 (SrcCode f)
    showsPrec p (SrcCode (ExUnfold t f)) = showParen (p > 3) $
        showString "unfold [" . shows (SrcCode t) . showString "] " . showsPrec 4 (SrcCode f)
    showsPrec _ (SrcCode (ExVar v)) = shows (SrcCode v)
    showsPrec _ (SrcCode (ExNatLit i)) = shows i
    showsPrec _ (SrcCode ExNull) = showChar '?'
    showsPrec _ (SrcCode ExUnit) = showString "()"
    showsPrec _ (SrcCode ExLeft) = showString "left"
    showsPrec _ (SrcCode ExRight) = showString "right"
    showsPrec _ (SrcCode ExCase) = showString "case"
    showsPrec _ (SrcCode ExFst) = showString "first"
    showsPrec _ (SrcCode ExSnd) = showString "second"
    showsPrec _ (SrcCode ExExpand) = showString "expand"
    showsPrec _ (SrcCode ExNever) = showString "never"
    showsPrec _ (SrcCode ExRace) = showString "race"
    showsPrec _ (SrcCode ExReflect) = showString "reflect"
    showsPrec _ (SrcCode ExUSwitch) = showString "ultraswitch"
    showsPrec _ (SrcCode (ExPack t)) = showString "pack [" . shows (SrcCode t) . showChar ']'
    showsPrec _ (SrcCode (ExUnpack t)) = showString "unpack [" . shows (SrcCode t) . showChar ']'
    showsPrec _ (SrcCode ExUJump) = showString "ultrajump"

instance Show (SrcCode Type) where
    showsPrec p (SrcCode (TyMu mu)) = showParen (p > 0) $ shows (SrcCode mu)
    showsPrec p (SrcCode (TyNu nu)) = showParen (p > 0) $ shows (SrcCode nu)
    showsPrec p (SrcCode (TyFun t1 t2)) = showParen (p > 1) $
        showsPrec 2 (SrcCode t1) . showString " -> " . showsPrec 1 (SrcCode t2)
    showsPrec p (SrcCode (TyPlus t1 t2)) = showParen (p > 2) $
        showsPrec 3 (SrcCode t1) . showString " + " . showsPrec 2 (SrcCode t2)
    showsPrec p (SrcCode (TyPair t1 t2)) = showParen (p > 3) $
        showsPrec 4 (SrcCode t1) . showString " * " . showsPrec 3 (SrcCode t2)
    showsPrec p (SrcCode (TyApp v [])) = shows (SrcCode v)
    showsPrec p (SrcCode (TyApp v vs)) = showParen (p > 4) $
        foldl (\f t -> f . showChar ' ' . (showsPrec 5 . SrcCode $ t)) (shows . SrcCode $ v) vs
    showsPrec p (SrcCode (TyBehav t)) = showParen (p > 4) $
        showString "behavior " . showsPrec 5 (SrcCode t)
    showsPrec p (SrcCode (TyEvent t)) = showParen (p > 4) $
        showString "event " . showsPrec 5 (SrcCode t)
    showsPrec _ (SrcCode TyNat) = showString "positive"
    showsPrec _ (SrcCode TyZero) = showChar '0'
    showsPrec _ (SrcCode TyUnit) = showChar '1'
    showsPrec _ (SrcCode (TyVar i)) = showChar '_' . showShortVar ['a'..'z'] 'v' i
    showsPrec _ (SrcCode (TyCon i)) = showChar '_' . showShortVar ['A'..'Z'] 'T' i

showShortVar :: [Char] -> Char -> Integer -> ShowS
showShortVar ls c i = if i<26 then showChar $ ls !! (fromInteger i)
                                  else showChar c . shows (i-26)

instance Show (SrcCode MuType) where
    showsPrec _ (SrcCode (MuType x t)) =
        showString "mu " . shows (SrcCode x) . showString " . " . showsPrec 1 (SrcCode t)


instance Show (SrcCode NuType) where
    showsPrec _ (SrcCode (NuType x t)) =
        showString "nu " . shows (SrcCode x) . showString " . " . showsPrec 1 (SrcCode t)


instance Show (SrcCode Var) where
    showsPrec _ (SrcCode (Var s)) = showString s