Syntax.hs

{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances, CPP,
             OverloadedStrings #-}
-- | Abstract syntax of Haste's intermediate format.
module Haste.AST.Syntax where
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Haste.AST.Op
import qualified Data.ByteString.Char8 as BS

type Arity = Int
type Comment = BS.ByteString
type Reorderable = Bool

-- | A Name consists of a variable name and optional (package, module)
--   information.
data Name = Name {
    nameIdent :: !BS.ByteString,
    nameQualifier :: !(Maybe (BS.ByteString, BS.ByteString))
  } deriving (Eq, Ord, Show)

class HasModule a where
  moduleOf :: a -> Maybe BS.ByteString
  pkgOf    :: a -> Maybe BS.ByteString

instance HasModule Name where
  moduleOf (Name _ mmod) = fmap snd mmod
  pkgOf (Name _ mmod)    = fmap fst mmod

instance HasModule Var where
  moduleOf (Foreign _)      = Nothing
  moduleOf (Internal n _ _) = moduleOf n
  pkgOf (Foreign _)         = Nothing
  pkgOf (Internal n _ _)    = pkgOf n

type KnownLoc = Bool

-- | Representation of variables.
data Var where
  Foreign  :: !BS.ByteString -> Var
  -- | Being a "known location" means that we can never substitute this
  --   variable for another one, as it is used to hold "return values" from
  --   case statements, tail loopification and similar.
  --   If a variable is *not* a known location, then we may always perform the
  --   substitution @a=b ; exp => exp [a/b]@.
  Internal :: !Name -> !Comment -> !KnownLoc -> Var
  deriving (Show)

isKnownLoc :: Var -> Bool
isKnownLoc (Internal _ _ knownloc) = knownloc
isKnownLoc _                       = False

instance Eq Var where
  {-# INLINE (==) #-}
  (Foreign f1)  == (Foreign f2)          = f1 == f2
  (Internal i1 _ _) == (Internal i2 _ _) = i1 == i2
  _ == _                                 = False

instance Ord Var where
  {-# INLINE compare #-}
  compare (Foreign f1) (Foreign f2)           = compare f1 f2
  compare (Internal i1 _ _) (Internal i2 _ _) = compare i1 i2
  compare (Foreign _) (Internal _ _ _)        = Prelude.LT
  compare (Internal _ _ _) (Foreign _)        = Prelude.GT

-- | Left hand side of an assignment. Normally we only assign internal vars,
--   but for some primops we need to assign array elements as well.
data LHS where
  -- | Introduce a new variable. May be reorderable.
  --   Invariant: a NewVar must be the first occurrence of a 'Var' in its
  --   scope.
  NewVar :: !Reorderable -> !Var -> LHS
  -- | Assign a value to an arbitrary LHS expression. May be reorderable.
  LhsExp :: !Reorderable -> !Exp -> LHS
  deriving (Eq, Show)

-- | Distinguish between normal, optimized and method calls.
--   Normal and optimized calls take a boolean indicating whether the called
--   function should trampoline or not. This defaults to True, and should
--   only be set to False when there is absolutely no possibility whatsoever
--   that the called function will tailcall.
data Call where
  Normal   :: !Bool          -> Call
  Fast     :: !Bool          -> Call
  Method   :: !BS.ByteString -> Call
  deriving (Eq, Show)

-- | Literals; nothing fancy to see here.
data Lit where
  LNum  :: !Double        -> Lit
  LStr  :: !BS.ByteString -> Lit
  LBool :: !Bool          -> Lit
  LInt  :: !Integer       -> Lit
  LNull :: Lit
  deriving (Eq, Show)

-- | Expressions. Completely predictable.
data Exp where
  Var       :: !Var -> Exp
  Lit       :: !Lit -> Exp
  -- | A literal JS snippet.
  --   Invariant: JSLits must not perform side effects or significant
  --   computation.
  JSLit     :: !BS.ByteString -> Exp
  Not       :: !Exp -> Exp
  BinOp     :: !BinOp -> Exp -> !Exp -> Exp
  Fun       :: ![Var] -> !Stm -> Exp
  Call      :: !Arity -> !Call -> !Exp -> ![Exp] -> Exp
  Index     :: !Exp -> !Exp -> Exp
  Member    :: !Exp -> !BS.ByteString -> Exp
  Arr       :: ![Exp] -> Exp
  Obj       :: ![(BS.ByteString, Exp)] -> Exp
  AssignEx  :: !Exp -> !Exp -> Exp
  IfEx      :: !Exp -> !Exp -> !Exp -> Exp
  Eval      :: !Exp -> Exp
  Thunk     :: !Bool -> !Stm -> Exp -- Thunk may be updatable or not
  deriving (Eq, Show)

-- | Is the given expression guaranteed to not be a thunk?
--   @definitelyNotThunk e <=> safe to skip evaluation of e@
definitelyNotThunk :: Exp -> Bool
definitelyNotThunk (Lit {})   = True
definitelyNotThunk (JSLit {}) = True
definitelyNotThunk (Not {})   = True
definitelyNotThunk (BinOp {}) = True
definitelyNotThunk (Fun {})   = True
definitelyNotThunk (Arr {})   = True
definitelyNotThunk (Eval {})  = True
definitelyNotThunk _          = False

-- | Statements. The only mildly interesting thing here are the Case and Jump
--   constructors, which allow explicit sharing of continuations.
data Stm where
  Case     :: !Exp -> !Stm -> ![Alt] -> !Stm -> Stm
  Forever  :: !Stm -> Stm
  Assign   :: !LHS -> !Exp -> !Stm -> Stm
  Return   :: !Exp -> Stm
  Cont     :: Stm
  Stop     :: Stm -- Do nothing at all past this point
  Tailcall :: !Exp -> Stm
  ThunkRet :: !Exp -> Stm -- Return from a Thunk
  deriving (Eq, Show)

-- | Case alternatives - an expression to match and a branch.
type Alt = (Exp, Stm)

-- | Represents a module. A module has a name, an owning
--   package, a dependency map of all its definitions, and a bunch of
--   definitions.
data Module = Module {
    modPackageId   :: !BS.ByteString,
    modName        :: !BS.ByteString,
    modDeps        :: M.Map Name (S.Set Name),
    modDefs        :: M.Map Name Exp,
    modSPT         :: [Name]
  }

-- | Merge two modules. The module and package IDs of the second argument are
--   used, and the second argument will take precedence for symbols which exist
--   in both.
merge :: Module -> Module -> Module
merge m1 m2 = Module {
    modPackageId = modPackageId m2,
    modName = modName m2,
    modDeps = M.union (modDeps m1) (modDeps m2),
    modDefs = M.union (modDefs m1) (modDefs m2),
    modSPT  = modSPT m1 ++ modSPT m2
  }

-- | Imaginary module for foreign code that may need one.
foreignModule :: Module
foreignModule = Module {
    modPackageId   = "",
    modName        = "",
    modDeps        = M.empty,
    modDefs        = M.empty,
    modSPT         = []
  }

-- | An LHS that's guaranteed to not ever be read, enabling the pretty
--   printer to ignore assignments to it.
blackHole :: LHS
blackHole = LhsExp False $ Var blackHoleVar

-- | Name of the data constructor tag field.
dataConTagField :: BS.ByteString
dataConTagField = "_"

-- | Infinite list of data constructor names.
dataConFieldNames :: [BS.ByteString]
dataConFieldNames = names
  where
    prefix  = BS.singleton '_'
    names   = concat [small, capital, map (BS.append prefix) names]
    small   = map BS.singleton ['a'..'z']
    capital = map BS.singleton ['A'..'Z']

-- | The global "zero object", which represents @{_:0}@.
zeroObject :: Exp
zeroObject = Var $ Foreign "__Z"

-- | The variable of the blackHole LHS.
blackHoleVar :: Var
blackHoleVar = Internal (Name "" (Just ("$blackhole", "$blackhole"))) "" False

-- | Returns the precedence of the top level operator of the given expression.
--   Everything that's not an operator has equal precedence, higher than any
--   binary operator.
expPrec :: Exp -> Int
expPrec (BinOp Sub (Lit (LNum 0)) _) = 500 -- 0-n is always printed as -n
expPrec (BinOp op _ _)               = opPrec op
expPrec (AssignEx _ _)               = 0
expPrec (Not _)                      = 500
expPrec _                            = 1000