module E.Type where
import Data.Foldable hiding(concat)
import Data.Traversable
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 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)
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 }
isLitInt (LitInt _ _) = True
isLitInt _ = False
isLitCons (LitCons _ _ _ _) = True
isLitCons _ = False
isEStar (EStar) = True
isEStar _ = False
isEBang (EBang) = True
isEBang _ = False
isEHash (EHash) = True
isEHash _ = False
isETuple (ETuple) = True
isETuple _ = False
isEHashHash (EHashHash) = True
isEHashHash _ = False
isEStarStar (EStarStar) = True
isEStarStar _ = False
isESortNamed (ESortNamed _) = True
isESortNamed _ = False
isEAp (EAp _ _) = True
isEAp _ = False
isELam (ELam _ _) = True
isELam _ = False
isEPi (EPi _ _) = True
isEPi _ = False
isEVar (EVar _) = True
isEVar _ = False
isUnknown (Unknown) = True
isUnknown _ = False
isESort (ESort _) = True
isESort _ = False
isELit (ELit _) = True
isELit _ = False
isELetRec (ELetRec _ _) = True
isELetRec _ = False
isEPrim (EPrim _ _ _) = True
isEPrim _ = False
isEError (EError _ _) = True
isEError _ = False
isECase (ECase _ _ _ _ _ _) = True
isECase _ = False
fromEAp (EAp aa ab) = return (aa,ab)
fromEAp _ = fail "fromEAp"
fromELam (ELam aa ab) = return (aa,ab)
fromELam _ = fail "fromELam"
fromEPi (EPi aa ab) = return (aa,ab)
fromEPi _ = fail "fromEPi"
fromEVar (EVar aa) = return (aa)
fromEVar _ = fail "fromEVar"
fromUnknown (Unknown) = return ()
fromUnknown _ = fail "fromUnknown"
fromESort (ESort aa) = return (aa)
fromESort _ = fail "fromESort"
fromELit (ELit aa) = return (aa)
fromELit _ = fail "fromELit"
fromELetRec (ELetRec aa ab) = return (aa,ab)
fromELetRec _ = fail "fromELetRec"
fromEPrim (EPrim aa ab ac) = return (aa,ab,ac)
fromEPrim _ = fail "fromEPrim"
fromEError (EError aa ab) = return (aa,ab)
fromEError _ = fail "fromEError"
fromECase (ECase aa ab ac ad ae af) = return (aa,ab,ac,ad,ae,af)
fromECase _ = fail "fromECase"
tvrIdent_u f r@TVr{tvrIdent = x} = r{tvrIdent = f x}
tvrInfo_u f r@TVr{tvrInfo = x} = r{tvrInfo = f x}
tvrType_u f r@TVr{tvrType = x} = r{tvrType = f x}
tvrIdent_s v = tvrIdent_u (const v)
tvrInfo_s v = tvrInfo_u (const v)
tvrType_s v = tvrType_u (const v)