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
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)
data Rule = Rule {
ruleHead :: TVr,
ruleBinds :: [TVr],
ruleArgs :: [E],
ruleNArgs :: !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)
data ESort =
EStar
| EBang
| EHash
| ETuple
| EHashHash
| EStarStar
| ESortNamed Name
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,
eCaseBind :: TVr,
eCaseAlts :: [Alt E],
eCaseDefault :: (Maybe E),
eCaseAllFV :: IdSet
}
deriving(Eq, Ord)
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
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]
fromAp :: E -> (E,[E])
fromAp e = f [] e where
f as (EAp e a) = f (a:as) e
f as e = (e,as)
fromPi :: E -> (E,[TVr])
fromPi e = f [] e where
f as (EPi v e) = f (v:as) e
f as e = (e,reverse as)
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 }
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 }
$(derive makeIs ''Lit)
$(derive makeIs ''ESort)
$(derive makeIs ''E)
$(derive makeFrom ''E)