module Yhc.Core.Invariant(
Invariant(..),
checkInvariant, ensureInvariant,
checkInvariants, ensureInvariants
) where
import Data.List
import Data.Maybe
import Yhc.Core.Type
import Yhc.Core.Uniplate
import Yhc.Core.UniqueName
import Yhc.Core.FreeVar3
import Yhc.Core.RecursiveLet
import Yhc.Core.Invariant.LambdaLift
data Invariant
= NoCoreLet
| NoCorePos
| CoreAppFun
| CoreAppCon
| NoEmptyApp
| CoreCaseVar
| NoCaseDefault
| NoCaseDefaultOne
| NoCaseConst
| NoRecursiveLet
| NoCoreLam
| NoPartialAppPrim
| NoPartialAppCon
| ConsecutiveFuncs
| UniqueVarsFunc
| UniqueVarsCore
| FuncArityAtMostOne
| FuncArityExactlyOne
deriving (Eq,Show,Enum,Bounded)
checkInvariants :: [Invariant] -> Core -> Bool
checkInvariants is = null . failingInvariants is
failingInvariants :: [Invariant] -> Core -> [Invariant]
failingInvariants is core = filter (not . flip checkInvariant core) is
checkInvariant :: Invariant -> Core -> Bool
checkInvariant = flip check
check core NoCoreLet = not $ any isCoreLet $ universeExpr core
check core NoCoreLam = not $ any isCoreLam $ universeExpr core
check core NoCorePos = not $ any isCorePos $ universeExpr core
check core NoRecursiveLet = not $ any isCoreLetRec $ universeExpr core
check core ConsecutiveFuncs = f ids
where
f (i:j:is) | i == j || i+1 == j = f (j:is)
f is = length is <= 1
ids = sort [i | func <- coreFuncs core, isCoreFunc func
, let i = snd $ uniqueSplit $ coreFuncName func, i > 2]
check core NoCaseDefaultOne = True
check core x = error $ "Yhc.Core.checkInvariant: Not yet implemented, " ++ show x
conflicts = [[CoreAppFun, NoEmptyApp], [CoreAppCon, NoEmptyApp]
,[NoCaseDefault, NoCaseDefaultOne], [FuncArityAtMostOne, FuncArityExactlyOne]
,[CoreCaseVar, NoCoreLet]
]
anyConflicts :: [Invariant] -> Bool
anyConflicts is = any ((> 1) . length . intersect is) conflicts
requires = [(NoCoreLet, [NoRecursiveLet])]
addRequires :: [Invariant] -> [Invariant]
addRequires is = is ++ concatMap (fromMaybe [] . flip lookup requires) is
order = concat [
[NoRecursiveLet, NoCoreLam]
]
bestOrder :: [Invariant] -> [Invariant]
bestOrder is = filter (`elem` is) items
where items = order ++ ([minBound..maxBound] \\ order)
validate :: [Invariant] -> Core -> Core
validate is c | null fails = c
| otherwise = error $ "Yhc.Core.ensureInvariants: BRAIN EXPLODED! " ++ show fails
where fails = failingInvariants is c
ensureInvariant :: Invariant -> Core -> Core
ensureInvariant i = ensureInvariants [i]
ensureInvariants :: [Invariant] -> Core -> Core
ensureInvariants is core
| anyConflicts is = error $ "Yhc.Core.ensureInvariants: conflicting invariants\n" ++ show is
| otherwise = validate is $ foldl ensure core $ bestOrder $ addRequires is
ensure core NoRecursiveLet = removeRecursiveLet core
ensure core NoCoreLam = coreLambdaLift core
ensure core NoCorePos = transformExpr remCorePos core
ensure core NoCoreLet = transformExpr f core
where
f (CoreLet bind x) = replaceFreeVars bind x
f x = x
ensure core NoCaseDefault = caseRemoveDefault True core
ensure core NoCaseDefaultOne = caseRemoveDefault False core
ensure core ConsecutiveFuncs = uniqueFuncsRename core
ensure core x = error $ "Yhc.Core.ensureInvariant: Not yet implemented, " ++ show x
caseRemoveDefault :: Bool -> Core -> Core
caseRemoveDefault alls core = transformExpr f core
where
check 0 = True
check n = alls || n == 1
f (CoreCase on alts)
| length alts > 1 && isPatDefault deflhs && not (null seen) &&
isJust dat && check (length missing)
= CoreCase on $ init alts ++ concatMap g (coreDataCtors $ fromJust dat)
where
(deflhs,defrhs) = last alts
missing = map coreCtorName (coreDataCtors $ fromJust dat) \\ seen
dat = coreCtorDataMaybe core (head seen)
seen = [c | (PatCon c _,_) <- alts]
free = freeVars 'v' \\ collectAllVars defrhs
g c | name `notElem` seen = [(PatCon name vars, defrhs)]
where
vars = take (length $ coreCtorFields c) free
name = coreCtorName c
g _ = []
f x = x