content: module E.E(
      Id(),
      IdMap(),
      IdSet(),
      newIds,
      module E.Type,
      module E.E,
      module E.FreeVars
      ) where
  
  import Data.Char(chr)
  import Data.Maybe
  import qualified Data.Traversable as T
  
  import C.Prims
  import Control.Monad.Identity
  import E.FreeVars
  import E.Type
  import Name.Id
  import Name.Name
  import Name.Names
  import Name.VConsts
  import Util.Gen
  
  isWHNF ELit {} = True
  isWHNF ELam {} = True
  isWHNF EPi {} = True
  isWHNF ESort {} = True
  isWHNF ELetRec { eBody = e } = isWHNF e
  isWHNF _ = False
  
  -----------
  -- E values
  -----------
  
  instance TypeNames E where
      tInt = ELit (litCons { litName = tInt, litArgs = [], litType = eStar })
      tRational = ELit (litCons { litName = tc_Ratio, litArgs = [tInteger], litType = eStar })
      tChar = ELit (litCons { litName = tChar, litArgs = [], litType = eStar })
      tBool = ELit (litCons { litName = tBool, litArgs = [], litType = eStar })
      tUnit = ELit (litCons { litName = tUnit, litArgs = [], litType = eStar })
      tString =  (ELit (litCons { litName = tc_List, litArgs = [tChar], litType = eStar }))
      tInteger = ELit (litCons { litName = tInteger, litArgs = [], litType = eStar })
      tWorld__ = ELit (litCons { litName = tc_State_, litArgs = [realWorld], litType = eHash }) where
          realWorld = ELit (litCons { litName = tc_RealWorld, litArgs = [], litType = eStar })
      tIntzh = ELit (litCons { litName = tIntzh, litArgs = [], litType = eHash })
      tEnumzh = ELit (litCons { litName = tEnumzh, litArgs = [], litType = eHash })
      tCharzh = ELit (litCons { litName = tCharzh, litArgs = [], litType = eHash, litAliasFor = Just tBits32zh })
  
  tIntegerzh = ELit (litCons { litName = rt_bits_max_, litArgs = [], litType = eHash })
  tBits32zh = ELit (litCons { litName = tIntzh, litArgs = [], litType = eHash })
  
  instance ConNames E where
      vTrue = ELit vTrue
      vFalse = ELit vFalse
      vUnit  = ELit vUnit
  
  instance ConNames (Lit E E) where
      vTrue  = (litCons { litName = dc_Boolzh, litArgs = [ELit lTruezh], litType = tBool })
      vFalse = (litCons { litName = dc_Boolzh, litArgs = [ELit lFalsezh], litType = tBool })
      vUnit  = (litCons { litName = dc_Unit, litArgs = [], litType = tUnit })
  
  -- values
  tFunc a b = ePi (tVr emptyId a) b
  tvrSilly = tVr sillyId Unknown
  tBoolzh = ELit litCons { litName = tc_Bool_, litType = eHash, litAliasFor = Just tEnumzh }
  lFalsezh = (LitInt 0 tBoolzh)
  lTruezh = (LitInt 1 tBoolzh)
  
  -----------------
  -- E constructors
  -----------------
  
  ePi a b = EPi a b
  
  eLam v (EError s t) = EError s (ePi v t)
  eLam v t = ELam v t
  
  -- | throw away first n EPi terms
  discardArgs :: Int -> E -> E
  discardArgs 0 e = e
  discardArgs n (EPi _ b) | n > 0 = discardArgs (n - 1) b
  discardArgs _ _ = error "discardArgs"
  
  tvrName :: Monad m => TVr  -> m Name
  tvrName (TVr {tvrIdent =  n }) | Just a <- fromId n = return a
  tvrName tvr = fail $ "TVr is not Name: " ++ show tvr
  
  tvrShowName :: TVr -> String
  tvrShowName t = show (tvrIdent t)
  
  modAbsurd = toModule "Jhc@.Absurd"
  modBox    = toModule "Jhc@.Box"
  
  nameConjured :: Module -> E -> Name
  nameConjured mod n = toName TypeConstructor (mod,f n "") where
      f (ESort s) = shows s
      f (EPi TVr { tvrType = t1 } t2) = ('^':) . f t1 . f t2
      f _ = error $ "nameConjured: " ++ show (mod,n)
  
  fromConjured :: Monad m => Module -> Name -> m E
  fromConjured mod n = maybeM ("fromConjured: " ++ show (mod,n)) $ do
      let f s = funit s `mplus` flam s
          flam ('^':xs) = do (x,rs) <- f xs; (y,gs) <- f rs; return (EPi tvr { tvrType = x } y,gs)
          flam _ = Nothing
          funit ('*':xs) = return (eStar,xs)
          funit ('#':xs) = return (eHash,xs)
          funit ('!':xs) = return (ESort EBang,xs)
          funit ('(':'#':')':xs) = return (ESort ETuple,xs)
          funit _ = Nothing
      (TypeConstructor,(mod',an)) <- return $  fromName n
      guard (mod' == mod)
      (r,"") <- f an
      return r
  
  isBottom EError {} = True
  isBottom _ = False
  
  caseBodiesMapM :: Monad m => (E -> m E) -> E -> m E
  caseBodiesMapM f ec@ECase { eCaseAlts = as, eCaseDefault = d } = do
      let g (Alt l e) = f e >>= return . Alt l
      as' <- mapM g as
      d' <- T.mapM f d
      return $ caseUpdate ec { eCaseAlts = as', eCaseDefault = d' }
  caseBodiesMapM _ _ = error "caseBodiesMapM"
  
  caseBodiesMap :: (E -> E) -> E -> E
  caseBodiesMap f ec = runIdentity $ caseBodiesMapM (\x -> return $ f x) ec
  
  eToList :: Monad m => E -> m  [E]
  eToList (ELit LitCons { litName = n, litArgs = [e,b] }) | dc_Cons == n = eToList b >>= \x -> return (e:x)
  eToList (ELit LitCons { litName = n, litArgs = [] }) | dc_EmptyList == n = return []
  eToList _ = fail "eToList: not list"
  
  toString (ELit LitCons { litName = n, litArgs = [], litType = t }) = if dc_EmptyList == n && t == tString then return "" else fail "not a string"
  toString x = eToList x >>= mapM fromChar where
      fromChar (ELit LitCons { litName = dc, litArgs = [ELit (LitInt ch t)] }) | dc == dc_Char = return (chr $ fromIntegral ch)
      fromChar _ = fail "fromChar: not char"
  
  ltTuple ts = ELit $ litCons { litName = nameTuple TypeConstructor (length ts), litArgs = ts, litType = eStar }
  ltTuple' ts = ELit $ litCons { litName = unboxedNameTuple TypeConstructor (length ts), litArgs = ts, litType = eHash }
  
  p_unsafeCoerce = primPrim "unsafeCoerce"
  p_dependingOn = primPrim "dependingOn"
  p_toTag = primPrim "toTag"
  p_fromTag = primPrim "fromTag"
  
  fromUnboxedTuple :: Monad m => E -> m [E]
  fromUnboxedTuple (ELit LitCons { litName = n, litArgs = as }) | Just _ <- fromUnboxedNameTuple n = return as
  fromUnboxedTuple _ = fail "fromUnboxedTuple: not a tuple"
  
  isUnboxedTuple m = isJust (fromUnboxedTuple m)
  
  instance Show E where
      showsPrec d (EAp aa ab) = showParen (d >= 10)
  	      (showString "EAp" . showChar ' ' . showsPrec 10 aa . showChar ' ' .
  	       showsPrec 10 ab)
      showsPrec d (ELam aa ab) = showParen (d >= 10)
  	      (showString "ELam" . showChar ' ' . showsPrec 10 aa
  	       . showChar ' ' . showsPrec 10 ab)
      showsPrec d (EPi aa ab) | tvrIdent aa == emptyId = showParen (d >= 10)
  	      (showsPrec 10 (tvrType aa) . showString " -> " .
  	       showsPrec 10 ab)
      showsPrec d (EPi aa ab) = showParen (d >= 10)
  	      (showString "EPi" . showChar ' ' . showsPrec 10 aa . showChar ' ' .
  	       showsPrec 10 ab)
      showsPrec d (EVar aa) = showParen (d >= 10)
  	      (showString "EVar" . showChar ' ' . showsPrec 10 aa)
      showsPrec d (Unknown) = showString "Unknown"
      showsPrec d (ESort aa) = showsPrec d aa
      --showsPrec d (ESort aa) = showParen (d >= 10)
      --          (showString "ESort" . showChar ' ' . showsPrec 10 aa)
      showsPrec d (ELit aa) = showsPrec 10 aa
      --showsPrec d (ELit aa) = showParen (d >= 10)
      --          (showString "ELit" . showChar ' ' . showsPrec 10 aa)
      showsPrec d (ELetRec aa ab) = showParen (d >= 10)
  	      (showString "ELetRec" . showChar '{' .
  	       showString "eDefs" . showChar '=' . showsPrec 10 aa
  	       . showChar ',' .
  	       showString "eBody" . showChar '=' . showsPrec 10 ab
  	       . showChar '}')
      showsPrec d (EPrim aa ab ac) = showParen (d >= 10)
  	      (showString "EPrim" . showChar ' ' . showsPrec 10 aa
  	       . showChar ' ' . showsPrec 10 ab . showChar ' ' . showsPrec 10 ac)
      showsPrec d (EError aa ab) = showParen (d >= 10)
  	      (showString "EError" . showChar ' ' . showsPrec 10 aa
  	       . showChar ' ' . showsPrec 10 ab)
      showsPrec d (ECase aa ab ac ad ae af) = showParen (d >= 10)
  	      (showString "ECase" . showChar '{' .
  	       showString "eCaseScrutinee" . showChar '=' . showsPrec 10 aa
  	       . showChar ',' .
  	       showString "eCaseType" . showChar '=' . showsPrec 10 ab
  	       . showChar ',' .
  	       showString "eCaseBind" . showChar '=' . showsPrec 10 ac
  	       . showChar ',' .
  	       showString "eCaseAlts" . showChar '=' . showsPrec 10 ad
  	       . showChar ',' .
  	       showString "eCaseDefault" . showChar '=' . showsPrec 10 ae
  	       . showChar ',' .
  	       showString "eCaseAllFV" . showChar '=' . showsPrec 10 af
  	       . showChar '}')
  
  instance Show e => Show (Alt e) where
      showsPrec n (Alt l e) = showParen (n > 10) $ shows l . showString " -> " . shows e
  