module MagicHaskeller.Expression(module MagicHaskeller.Expression, module MagicHaskeller.ExprStaged, CoreExpr) where
import MagicHaskeller.CoreLang
import MagicHaskeller.MyDynamic
import MagicHaskeller.Execute
import MagicHaskeller.Types
import MagicHaskeller.ExprStaged
import MagicHaskeller.Combinators
import MagicHaskeller.T10
import Control.Monad
import Data.Array((!), array)
import MagicHaskeller.ReadDynamic
import MagicHaskeller.TyConLib(defaultTCL, TyConLib)
import MagicHaskeller.Instantiate(RTrie, uncurryDyn, uncurryTy, mkUncurry, mkCurry, curryDyn)
import MagicHaskeller.DebMT
import qualified Data.Set as S
import qualified Data.IntMap as IM
import Data.List(sortBy, genericIndex)
data AnnExpr = AE CoreExpr Dynamic deriving Show
instance Eq AnnExpr where
a == b = toCE a == toCE b
instance Ord AnnExpr where
compare a b = compare (toCE a) (toCE b)
data MemoExpr = ME CoreExpr Dynamic
Dynamic
aeToME :: TyConLib -> RTrie -> Type -> AnnExpr -> MemoExpr
aeToME tcl (_,_,_,_,mtdd) ty@(_:->_) (AE ce dyn)
= case lookupMT mtdd argty of (m,a) -> let me@(ME _ memo _) = ME ce (dynApp m udyn) (curryDyn cur ty $ dynApp a memo)
in me
where argty:->_ = uncurryTy tcl ty
unc = mkUncurry tcl
udyn = uncurryDyn unc ty dyn
cur = mkCurry tcl
aeToME _ _ _ (AE ce dyn) = ME ce undefined dyn
meToAE :: MemoExpr -> AnnExpr
meToAE (ME ce _ f) = AE ce f
class (Ord e, Show e) => Expression e where
mkHead :: (Integral i, Integral j) => (CoreExpr->Dynamic) -> i -> j -> CoreExpr -> e
toCE :: e -> CoreExpr
fromCE :: (CoreExpr -> Dynamic) -> CoreExpr -> e
mapCE :: (CoreExpr -> CoreExpr) -> e -> e
aeAppErr :: String -> e -> e -> e
appEnv :: Int8 -> e -> e -> e
toAnnExpr :: (CoreExpr->Dynamic) -> e -> AnnExpr
toAnnExprWind :: (CoreExpr->Dynamic) -> Type -> e -> AnnExpr
toAnnExprWindWind :: (CoreExpr->Dynamic) -> Type -> e -> AnnExpr
fromAnnExpr :: AnnExpr -> e
reorganize :: Monad m => ([Type] -> m [e]) -> [Type] -> m [e]
reorganize' :: Monad m => ([Type] -> m [e]) -> [Type] -> m [e]
reorganizeId :: ([Type] -> [e]) -> [Type] -> [e]
replaceVars' :: Int8 -> e -> [Int8] -> e
reorganizeId' :: (Functor m) => ([Type] -> m e) -> [Type] -> m e
reorganizeId' fun avail = case cvtAvails' avail of
(args, newavail) ->
fmap (\e -> replaceVars' 0 e args) $ fun newavail
instance Expression CoreExpr where
mkHead _ _ _ = id
toCE = id
fromCE _ = id
mapCE = id
aeAppErr _msg = (:$)
appEnv _ = (:$)
toAnnExpr reduce e = AE e (reduce e)
toAnnExprWind reduce ty e = AE e (reduce $ windType ty e)
toAnnExprWindWind reduce ty e = let we = windType ty e in AE we (reduce we)
fromAnnExpr (AE ce _) = ce
reorganize = reorganizer
reorganize' = reorganizeCE'
reorganizeId = reorganizerId
replaceVars' = replaceVarsCE'
instance Expression AnnExpr where
mkHead reduce lenavails arity ce = mkHeadAE reduce (fromIntegral lenavails) (fromIntegral arity) ce
toCE (AE ce _) = ce
fromCE = toAnnExpr
mapCE f (AE ce d) = AE (f ce) d
#ifdef REALDYNAMIC
aeAppErr msg (AE e1 h1) (AE e2 h2) = AE (e1:$e2) (dynAppErr (" while applying "++show e1 ++" to "++show e2 ++ '\n':msg) h1 h2)
#else
aeAppErr _msg (AE e1 h1) (AE e2 h2) = AE (e1:$e2) (dynApp h1 h2)
#endif
appEnv lenavails (AE e1 h1) (AE e2 h2) = AE (e1:$e2) (dynApp (dynApp (dynSn lenavails) h1) h2)
toAnnExpr _ = id
toAnnExprWind _ _ = id
toAnnExprWindWind _ ty (AE ce d) = AE (windType ty ce) d
fromAnnExpr = id
reorganize = id
reorganize' = id
reorganizeId = id
reorganizeId' = id
(<$>) :: Expression e => e -> e -> e
(<$>) = aeAppErr ""
mkHeadAE _ lenavails arity ce@(X i) = AE ce (getDyn_LambdaBoundHead i lenavails arity)
mkHeadAE reduce lenavails arity ce = AE ce ((getDyn lenavails arity) `dynApp` reduce ce)
windType :: Type -> CoreExpr -> CoreExpr
windType (a:->b) e = Lambda (windType b e)
windType _ e = e
dynSn lenavails = dynApp (getDyn lenavails 2) dynI
getDyn, mkDyn :: Int8 -> Int8 -> Dynamic
getDyn lenavails arity
| lenavails<=maxLenavails && arity<=maxArity =
finiteDynar ! (lenavails,arity)
| otherwise = dynss `genericIndex` lenavails `genericIndex` arity
dynss :: [[Dynamic]]
dynss = [ [ mkDyn i j | j <- [0..] ] | i <- [0..] ]
mkDyn 0 _ = dynI
mkDyn lenavails arity = dynApp (dynB `dynApp` x arity) (getDyn (lenavails1) arity)
x 0 = dynK
x 1 = dynB
x 2 = dynS'
x n = napply n (dynApp dynB) dynS `dynApp` x (n1)
finiteDynar = array ((0,0),(maxLenavails,maxArity)) [ ((lenavails,arity), finiteDynss `genericIndex` lenavails `genericIndex` arity) | arity<-[0..maxArity], lenavails<-[0..maxLenavails] ]
finiteDynarr = array ((0,0,0),(maxDebindex,maxLenavails,maxArity)) [ ((debindex,lenavails,arity), finiteDynsss `genericIndex` debindex `genericIndex` (lenavailsdebindex1) `genericIndex` arity) | arity<-[0..maxArity], debindex<-[0..maxDebindex], lenavails<-[debindex+1..maxLenavails] ]
finiteDynss = zipWith3 (zipWith3 (unsafeToDyn defaultTCL)) [ [ hdmnty arity lenavails | arity <- [0..maxArity] ] | lenavails <- [0..maxLenavails] ]
finiteHVss
[ [ hdmnTHE arity lenavails | arity <- [0..maxArity] ] | lenavails <- [0..maxLenavails] ]
finiteDynsss = zipWith3 (zipWith3 (zipWith3 (unsafeToDyn defaultTCL)))
[ [ [ aimnty debindex arity lenavails | arity <- [0..maxArity] ] | lenavails <- [debindex+1..maxLenavails] ] | debindex <- [0..maxDebindex] ]
finiteHVsss
[ [ [ aimnTHE debindex arity lenavails | arity <- [0..maxArity] ] | lenavails <- [debindex+1..maxLenavails] ] | debindex <- [0..maxDebindex] ]
getDyn_LambdaBoundHead, mkDyn_LambdaBoundHead :: Int8 -> Int8 -> Int8 -> Dynamic
getDyn_LambdaBoundHead debindex lenavails arity
| debindex<=maxDebindex && lenavails<=maxLenavails && arity<=maxArity =
finiteDynarr ! (debindex,lenavails,arity)
| otherwise = dynsss `genericIndex` debindex `genericIndex` lenavails `genericIndex` arity
dynsss :: [[[Dynamic]]]
dynsss = [ [ [ mkDyn_LambdaBoundHead i j k | k <- [0..] ] | j <- [0..] ] | i <- [0..] ]
mkDyn_LambdaBoundHead debindex lenavails arity = (getDyn lenavails (arity+1) `dynApp` dynI) `dynApp` select lenavails debindex
where
select lenavails debindex = napply (lenavails1debindex) (dynApp dynK) $ napply debindex (dynApp dynBK) dynI
dynBK = dynApp dynB dynK
reorganizer :: Monad m => ([Type] -> m [CoreExpr]) -> [Type] -> m [CoreExpr]
reorganizer fun avail
= case cvtAvails avail of
(newavail, argss) ->
do agentExprs <- fun newavail
return [ result | e <- agentExprs, result <- replaceVars 0 e argss ]
reorganizerId :: ([Type] -> [CoreExpr]) -> [Type] -> [CoreExpr]
reorganizerId fun avail
= case cvtAvails avail of
(newavail, argss) ->
[ result | e <- fun newavail, result <- replaceVars 0 e argss ]
replaceVars :: Int8 -> CoreExpr -> [[Int8]] -> [CoreExpr]
replaceVars dep e@(X n) argss = case argss !? (n dep) of Nothing -> [e]
Just xs -> map (\ m -> X (m + dep)) xs
replaceVars dep (Lambda e) argss = map Lambda (replaceVars (dep+1) e argss)
replaceVars dep (f :$ e) argss = liftM2 (:$) (replaceVars dep f argss) (replaceVars dep e argss)
replaceVars dep e argss = [e]
cvtAvails = unzip . tkr10 . annotate
tkr10 :: [(Type,a)] -> [(Type,[a])]
tkr10 = mergesortWithBy (\ (k,is) (_,js) -> (k,is++js)) (\ (k,_) (l,_) -> k `compare` l) . map (\(k,i)->(k,[i]))
annotate :: [Type] -> [(Type,Int8)]
annotate ts = zipWith (,) ts [0..]
reorganizeCE' :: Monad m => ([Type] -> m [CoreExpr]) -> [Type] -> m [CoreExpr]
reorganizeCE' fun avail
= case cvtAvails' avail of
(args, newavail) ->
do agentExprs <- fun newavail
return [ replaceVars' 0 e args | e <- agentExprs ]
replaceVarsCE' :: Int8 -> CoreExpr -> [Int8] -> CoreExpr
replaceVarsCE' dep e@(X n) args = case args !? (n dep) of Nothing -> e
Just m -> X (m + dep)
replaceVarsCE' dep (Lambda e) args = Lambda (replaceVarsCE' (dep+1) e args)
replaceVarsCE' dep (f :$ e) args = replaceVarsCE' dep f args :$ replaceVarsCE' dep e args
replaceVarsCE' dep e args = e
cvtAvails' = unzip . sortBy (\(_,k) (_,l) -> compare k l) . zip [0..]
uniqSorter, uniqSortPatAVL :: (Expression e) => [(e,Int)] -> [(e,Int)]
uniqSorter = swapUniqSort
uniqSort, uniqSortAVL :: Ord a => [a] -> [a]
uniqSort = mergesortWithBy const compare
swapUniqSort :: (Ord a, Ord b) => [(a,b)] -> [(a,b)]
swapUniqSort = mergesortWithBy const (\(a,b) (c,d) -> compare (b,a) (d,c))
uniqSortAVL = S.toList . S.fromList
uniqSortPatAVL ts = [ (x,j) | (j, set) <- IM.toList $ IM.fromListWith S.union $ map (\(x,i) -> (i, S.singleton x)) ts
, x <- S.toList set ]