E.hs

{-# OPTIONS -fglasgow-exts #-}
module E.E(
    Id(),
    IdMap(),
    IdSet(),
    newIds,
    module E.Type,
    module E.E,
    module E.FreeVars
    ) where

import Char(chr)
import qualified Data.Traversable as T
import List
import Maybe

import E.FreeVars
import C.Prims
import Control.Monad.Identity
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
    tStar = eStar
    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 = tWorld__, litArgs = [], litType = eHash })
    tIntzh = ELit (litCons { litName = tIntzh, litArgs = [], litType = eHash })
    tEnumzh = ELit (litCons { litName = tEnumzh, litArgs = [], litType = eHash })
    tIntegerzh = ELit (litCons { litName = tIntegerzh, litArgs = [], litType = eHash })
    tCharzh = ELit (litCons { litName = tCharzh, 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 (LitInt 1 tEnumzh)], litType = tBool })
    vFalse = (litCons { litName = dc_Boolzh, litArgs = [ELit (LitInt 0 tEnumzh)], litType = tBool })
    vUnit  = (litCons { litName = vUnit, litArgs = [], litType = tUnit })



tFunc a b = ePi (tVr emptyId a) b

-- values



tvrSilly = tVr sillyId Unknown

-----------------
-- 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 = maybe ('x':(show $ tvrIdent t)) show (tvrName t)


modAbsurd = "Lhc@.Absurd"
modBox    = "Lhc@.Box"


nameConjured :: String -> E -> Name
nameConjured mod n = toName TypeConstructor (mod,f n "") where
    f (ESort s) = shows s
    f (EPi TVr { tvrType = t1 } t2) = ('^':) . shows t1 . shows t2
    f _ = error $ "nameConjured: " ++ show (mod,n)

fromConjured :: Monad m => String -> 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"

eToList :: Monad m => E -> m  [E]
eToList (ELit LitCons { litName = n, litArgs = [e,b] }) | vCons == n = eToList b >>= \x -> return (e:x)
eToList (ELit LitCons { litName = n, litArgs = [] }) | vEmptyList == n = return []
eToList _ = fail "eToList: not list"

toString (ELit LitCons { litName = n, litArgs = [], litType = t }) = if vEmptyList == 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 && t == tCharzh = 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)