Type.hs

{-# LANGUAGE TemplateHaskell #-}
-- | The definitions related to jhc core

module E.Type where

import Data.Foldable hiding(concat)
import Data.Traversable
import Data.DeriveTH

import C.Prims
import Cmm.Number
import Doc.DocLike hiding((<$>))
import Info.Types
import Name.Id
import Name.Name
import Name.Names
import StringTable.Atom
import Util.Gen
import Util.SetLike
import qualified Info.Info as Info

{- @Internals

# Jhc core normalized forms

Jhc core has a number of 'normalized forms' in which certain invarients are
met. many routines expect code to be in a certain form, and guarentee theier
output is also in a given form. The type system also can change with each form
by adding/removing terms from the PTS axioms and rules.

normalized form alpha
: There are basically no restrictions other than the code is typesafe, but
certain constructs that are checked by the type checker are okay when they
wouldn't otherwise be. In particular, 'newtype' casts still exist at the data
level.  'enum' scrutinizations are creations may be in terms of the virtual
constructors rather than the internal representations. let may bind unboxed
values, which is normaly not allowed.

normalized form beta
: This is like alpha except all data type constructors and case scrutinizations
are in their final form. As in, newtype coercions are removed, Enums are
desugared etc. also, 'let' bindings of unboxed values are translated to the
appropriate 'case' statements. The output of E.FromHs is in this form.

normalized form blue
: This is the form that most routines work on.

normalized form larry
: post lambda-lifting

normalized form mangled
: All polymorphism has been replaced with subtyping

-}

-- the type of a supercombinator
data Comb = Comb {
    combHead :: TVr,
    combBody :: E,
    combRules :: [Rule]
    }

instance HasProperties Comb where
    modifyProperties f comb = combHead_u (modifyProperties f) comb
    getProperties comb = getProperties $ combHead comb
    putProperties p comb = combHead_u (putProperties p) comb

instance HasProperties TVr where
    modifyProperties f = tvrInfo_u (modifyProperties f)
    getProperties = getProperties . tvrInfo
    putProperties prop =  tvrInfo_u (putProperties prop)

combBody_u f r@Comb{combBody  = x} = r{combBody = f x}
combHead_u f r@Comb{combHead  = x} = r{combHead = f x}
combRules_u f r@Comb{combRules  = x} = cp r{combRules = fx} where
    cp = if null fx then unsetProperty PROP_HASRULE else setProperty PROP_HASRULE
    fx = f x

combBody_s v =  combBody_u  (const v)
combHead_s v =  combHead_u  (const v)
combRules_s v =  combRules_u  (const v)

emptyComb = Comb { combHead = tvr, combBody = Unknown, combRules = [] }
combIdent = tvrIdent . combHead
combArgs  = snd . fromLam . combBody
combABody = fst . fromLam . combBody
combBind b = (combHead b,combBody b)
bindComb (t,e) = combHead_s t . combBody_s e $ emptyComb
combTriple comb = (combHead comb,combArgs comb,combABody comb)
combTriple_s (t,as,e) comb = comb { combHead = t, combBody = Prelude.foldr ELam e as }

data RuleType = RuleSpecialization | RuleUser | RuleCatalyst
    deriving(Eq)

-- a rule in its user visible form

data Rule = Rule {
    ruleHead :: TVr,
    ruleBinds :: [TVr],
    ruleArgs :: [E],
    ruleNArgs :: {-# UNPACK #-} !Int,
    ruleBody :: E,
    ruleType :: RuleType,
    ruleUniq :: (Module,Int),
    ruleName :: Atom
    }

data ARules = ARules {
    aruleFreeVars :: IdSet,
    aruleRules :: [Rule]
    }

data Lit e t = LitInt { litNumber :: Number, litType :: t }
    | LitCons  { litName :: Name, litArgs :: [e], litType :: t, litAliasFor :: Maybe E }
    deriving(Eq,Ord,Functor,Foldable,Traversable)

--------------------------------------
-- Lambda Cube (it's just fun to say.)
-- We are now based on a PTS, which is
-- a generalization of the lambda cube
-- see E.TypeCheck for a description
-- of the type system.
--------------------------------------

data ESort =
    EStar         -- ^ the sort of boxed lazy types
    | EBang       -- ^ the sort of boxed strict types
    | EHash       -- ^ the sort of unboxed types
    | ETuple      -- ^ the sort of unboxed tuples
    | EHashHash   -- ^ the supersort of unboxed types
    | EStarStar   -- ^ the supersort of boxed types
    | ESortNamed Name -- ^ user defined sorts
    deriving(Eq, Ord)

data E = EAp E E
    | ELam TVr E
    | EPi TVr E
    | EVar TVr
    | Unknown
    | ESort ESort
    | ELit !(Lit E E)
    | ELetRec { eDefs :: [(TVr, E)], eBody :: E }
    | EPrim Prim [E] E
    | EError String E
    | ECase {
       eCaseScrutinee :: E,
       eCaseType :: E, -- due to GADTs and typecases, the final type of the expression might not be so obvious, so we include it here.
       eCaseBind :: TVr,
       eCaseAlts :: [Alt E],
       eCaseDefault :: (Maybe E),
       eCaseAllFV  :: IdSet
       }
	deriving(Eq, Ord)

--instance Functor (Lit e) where
--    fmap f x = runIdentity $ fmapM (return . f) x

--instance FunctorM (Lit e) where
--    fmapM f x = case x of
--        LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af } -> do  e <- f e; return LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af }
--        LitInt i t -> do t <- f t; return $ LitInt i t

instance Show ESort where
    showsPrec _ EStar = showString "*"
    showsPrec _ EHash = showString "#"
    showsPrec _ EStarStar = showString "**"
    showsPrec _ EHashHash = showString "##"
    showsPrec _ ETuple = showString "(#)"
    showsPrec _ EBang = showString "!"
    showsPrec _ (ESortNamed n) = shows n

instance (Show e,Show t) => Show (Lit e t) where
    showsPrec p (LitInt x t) = showParen (p > 10) $  shows x <> showString "::" <> shows t
    showsPrec p LitCons { litName = n, litArgs = es, litType = t } = showParen (p > 10) $ hsep (shows n:map (showsPrec 11) es) <> showString "::" <> shows t

instance Show a => Show (TVr' a) where
    showsPrec n TVr { tvrIdent = eid, tvrType = e} | eid == emptyId = showParen (n > 10) $ showString "_::" . shows e
    showsPrec n TVr { tvrIdent = x, tvrType = e} = showParen (n > 10) $ case fromId x of
        Just n -> shows n . showString "::" . shows e
        Nothing  -> shows x . showString "::" . shows e

type TVr = TVr' E
data TVr' e = TVr { tvrIdent :: !Id, tvrType :: e, tvrInfo :: Info.Info }
    deriving(Functor,Foldable,Traversable)

tvrInfo_u f r@TVr{tvrInfo  = x} = r{tvrInfo = f x}
tvrType_u f r@TVr{tvrType  = x} = r{tvrType = f x}
tvrInfo_s v =  tvrInfo_u  (const v)
tvrType_s v =  tvrType_u  (const v)

data Alt e = Alt (Lit TVr e) e
    deriving(Eq,Ord)

instance Eq TVr where
    (==) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i == i'
    (/=) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i /= i'

instance Ord TVr where
    compare (TVr { tvrIdent = x }) (TVr { tvrIdent = y }) = compare x y
    x < y = tvrIdent x < tvrIdent y
    x > y = tvrIdent x > tvrIdent y
    x >= y = tvrIdent x >= tvrIdent y
    x <= y = tvrIdent x <= tvrIdent y

-- simple querying routines
altHead :: Alt E -> Lit () ()
altHead (Alt l _) = litHead  l

litHead :: Lit a b -> Lit () ()
litHead (LitInt x _) = LitInt x ()
litHead LitCons { litName = s, litAliasFor = af } = litCons { litName = s, litType = (), litAliasFor = af }

litBinds (LitCons { litArgs = xs } ) = xs
litBinds _ = []

patToLitEE LitCons { litName = n, litArgs = [a,b], litType = t } | t == eStar, n == tc_Arrow = EPi (tVr emptyId (EVar a)) (EVar b)
patToLitEE LitCons { litName = n, litArgs = xs, litType = t, litAliasFor = af } = ELit $ LitCons { litName = n, litArgs = (map EVar xs), litType = t, litAliasFor = af }
patToLitEE (LitInt x t) = ELit $ LitInt x t

caseBodies :: E -> [E]
caseBodies ec = [ b | Alt _ b <- eCaseAlts ec] ++ maybeToMonad (eCaseDefault ec)
casePats ec =  [ p | Alt p _ <- eCaseAlts ec]
caseBinds ec = eCaseBind ec : concat [ xs  | LitCons { litArgs = xs } <- casePats ec]

-- | extract out EAp nodes a value and the arguments it is applied to.
fromAp :: E -> (E,[E])
fromAp e = f [] e where
    f as (EAp e a) = f (a:as) e
    f as e  =  (e,as)

-- | deconstruct EPi terms, getting function argument types.

fromPi :: E -> (E,[TVr])
fromPi e = f [] e where
    f as (EPi v e) = f (v:as) e
    f as e  =  (e,reverse as)

-- | deconstruct ELam term.

fromLam :: E -> (E,[TVr])
fromLam e = f [] e where
    f as (ELam v e) = f (v:as) e
    f as e  =  (e,reverse as)

litCons = LitCons { litName = error "litName: name not set", litArgs = [], litType = error "litCons: type not set", litAliasFor = Nothing }

-----------------
-- E constructors
-----------------

eStar :: E
eStar = ESort EStar

eHash :: E
eHash = ESort EHash

tVr x y = tvr { tvrIdent = x, tvrType = y }
tvr = TVr { tvrIdent = emptyId, tvrType = Unknown, tvrInfo = Info.empty }

--  Imported from other files :-

$(derive makeIs ''Lit)
$(derive makeIs ''ESort)
$(derive makeIs ''E)
$(derive makeFrom ''E)