forked from GitHub/gf-core
Revert bubble re-implementation
This commit is contained in:
Eve
@@ -394,81 +394,138 @@ apply g (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs)
|
|||||||
apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
|
apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
|
||||||
apply g v [] = v
|
apply g v [] = v
|
||||||
|
|
||||||
data Bubbled a
|
data BubbleVariants
|
||||||
= BLeaf a
|
= BubbleFree Int
|
||||||
| BFree Choice [Bubbled a]
|
| BubbleOpts Value Value [(Value, Value)]
|
||||||
| BOpts Choice Value Value [(Value, Value, Bubbled a)]
|
|
||||||
|
|
||||||
instance Functor Bubbled where
|
bubble v = snd (bubble v)
|
||||||
fmap = liftM
|
|
||||||
|
|
||||||
instance Applicative Bubbled where
|
|
||||||
pure = BLeaf
|
|
||||||
(<*>) = ap
|
|
||||||
|
|
||||||
instance Monad Bubbled where
|
|
||||||
BLeaf a >>= k = k a
|
|
||||||
BFree c as >>= k = BFree c ((>>= k) <$> as)
|
|
||||||
BOpts c nty n as >>= k = BOpts c nty n (third (>>= k) <$> as)
|
|
||||||
|
|
||||||
unbubble :: Bubbled Value -> Value
|
|
||||||
unbubble (BLeaf v) = v
|
|
||||||
unbubble (BFree c vs) = VFV c (VarFree (unbubble <$> vs))
|
|
||||||
unbubble (BOpts c nty n cs) = VFV c (VarOpts nty n (third unbubble <$> cs))
|
|
||||||
|
|
||||||
bubble v = unbubble (bubble' v)
|
|
||||||
where
|
where
|
||||||
bubble' :: Value -> Bubbled Value
|
bubble (VApp c f vs) = liftL (VApp c f) vs
|
||||||
bubble' (VApp c f vs) = liftL (VApp c f) vs
|
bubble (VMeta metaid vs) = liftL (VMeta metaid) vs
|
||||||
bubble' (VMeta metaid vs) = liftL (VMeta metaid) vs
|
bubble (VSusp metaid k vs) = liftL (VSusp metaid k) vs
|
||||||
bubble' (VSusp metaid k vs) = liftL (VSusp metaid k) vs
|
bubble (VGen i vs) = liftL (VGen i) vs
|
||||||
bubble' (VGen i vs) = liftL (VGen i) vs
|
bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env
|
||||||
bubble' (VClosure env c t) = liftL' (\env -> VClosure env c t) env
|
bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
|
||||||
bubble' (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
|
bubble (VRecType as) = liftL' VRecType as
|
||||||
bubble' (VRecType as) = liftL' VRecType as
|
bubble (VR as) = liftL' VR as
|
||||||
bubble' (VR as) = liftL' VR as
|
bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
|
||||||
bubble' (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
|
bubble (VExtR v1 v2) = lift2 VExtR v1 v2
|
||||||
bubble' (VExtR v1 v2) = lift2 VExtR v1 v2
|
bubble (VTable v1 v2) = lift2 VTable v1 v2
|
||||||
bubble' (VTable v1 v2) = lift2 VTable v1 v2
|
bubble (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env
|
||||||
bubble' (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env
|
bubble (VV v vs) = lift1L VV v vs
|
||||||
bubble' (VV v vs) = lift1L VV v vs
|
bubble (VS v1 v2 vs) = lift2L VS v1 v2 vs
|
||||||
bubble' (VS v1 v2 vs) = lift2L VS v1 v2 vs
|
bubble v@(VSort _) = lift0 v
|
||||||
bubble' v@(VSort _) = lift0 v
|
bubble v@(VInt _) = lift0 v
|
||||||
bubble' v@(VInt _) = lift0 v
|
bubble v@(VFlt _) = lift0 v
|
||||||
bubble' v@(VFlt _) = lift0 v
|
bubble v@(VStr _) = lift0 v
|
||||||
bubble' v@(VStr _) = lift0 v
|
bubble v@VEmpty = lift0 v
|
||||||
bubble' v@VEmpty = lift0 v
|
bubble (VC v1 v2) = lift2 VC v1 v2
|
||||||
bubble' (VC v1 v2) = lift2 VC v1 v2
|
bubble (VGlue v1 v2) = lift2 VGlue v1 v2
|
||||||
bubble' (VGlue v1 v2) = lift2 VGlue v1 v2
|
bubble v@(VPatt _ _ _) = lift0 v
|
||||||
bubble' v@(VPatt _ _ _) = lift0 v
|
bubble (VPattType v) = lift1 VPattType v
|
||||||
bubble' (VPattType v) = lift1 VPattType v
|
bubble v@(VFV c (VarFree vs))
|
||||||
bubble' (VFV c (VarFree vs)) = BFree c (bubble' <$> vs)
|
| null vs = (Map.empty, v)
|
||||||
bubble' (VFV c (VarOpts nty n os)) = BOpts c nty n (third bubble' <$> os)
|
| otherwise = let (union,vs') = mapAccumL descend Map.empty vs
|
||||||
bubble' (VAlts v vs) = lift1L2 VAlts v vs
|
b = BubbleFree (length vs)
|
||||||
bubble' (VStrs vs) = liftL VStrs vs
|
v' = addVariants (VFV c (VarFree vs')) union
|
||||||
bubble' (VMarkup tag attrs vs) = do
|
in (Map.insert c (b,1) union, v')
|
||||||
attrs' <- mapM (secondM bubble') attrs
|
bubble v@(VFV c (VarOpts nty n os))
|
||||||
vs' <- mapM bubble' vs
|
| null os = (Map.empty, v)
|
||||||
return $ VMarkup tag attrs' vs'
|
| otherwise = let (union,os') = mapAccumL (\acc (lty,l,v) -> second (lty,l,) $ descend acc v) Map.empty os
|
||||||
bubble' (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
|
b = BubbleOpts nty n (os <&> \(lty,l,_) -> (lty,l))
|
||||||
bubble' (VSymCat d i0 vs) = do
|
v' = addVariants (VFV c (VarOpts nty n os')) union
|
||||||
vs' <- forM vs $ \(i,(v,ty)) -> (i,) . (,ty) <$> bubble' v
|
in (Map.insert c (b,1) union, v')
|
||||||
return $ VSymCat d i0 vs'
|
bubble (VAlts v vs) = lift1L2 VAlts v vs
|
||||||
bubble' v@(VError _) = lift0 v
|
bubble (VStrs vs) = liftL VStrs vs
|
||||||
bubble' v@(VCRecType lbls) = do
|
bubble (VMarkup tag attrs vs) =
|
||||||
lbls' <- forM lbls $ \(l,b,v) -> (l,b,) <$> bubble' v
|
let (union1,attrs') = mapAccumL descend' Map.empty attrs
|
||||||
return $ VCRecType lbls'
|
(union2,vs') = mapAccumL descend union1 vs
|
||||||
bubble' v@(VCInts _ _) = lift0 v
|
in (union2, VMarkup tag attrs' vs')
|
||||||
|
bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
|
||||||
|
bubble (VSymCat d i0 vs) =
|
||||||
|
let (union,vs') = mapAccumL descendC Map.empty vs
|
||||||
|
in (union, addVariants (VSymCat d i0 vs') union)
|
||||||
|
bubble v@(VError _) = lift0 v
|
||||||
|
bubble v@(VCRecType lbls) =
|
||||||
|
let (union,lbls') = mapAccumL descendR Map.empty lbls
|
||||||
|
in (union, addVariants (VCRecType lbls') union)
|
||||||
|
bubble v@(VCInts _ _) = lift0 v
|
||||||
|
|
||||||
lift0 = BLeaf
|
lift0 v = (Map.empty, v)
|
||||||
lift1 f v = f <$> bubble' v
|
|
||||||
liftL f vs = f <$> mapM bubble' vs
|
lift1 f v =
|
||||||
liftL' f xvs = f <$> mapM (secondM bubble') xvs
|
let (union,v') = bubble v
|
||||||
lift1L f v vs = liftM2 f (bubble' v) (mapM bubble' vs)
|
in (union,f v')
|
||||||
lift1L' f v xvs = liftM2 f (bubble' v) (mapM (secondM bubble') xvs)
|
|
||||||
lift1L2 f v uvs = liftM2 f (bubble' v) (mapM (bimapM bubble' bubble') uvs)
|
liftL f vs =
|
||||||
lift2L f v1 v2 vs = liftM3 f (bubble' v1) (bubble' v2) (mapM bubble' vs)
|
let (union,vs') = mapAccumL descend Map.empty vs
|
||||||
lift2 f v1 v2 = liftM2 f (bubble' v1) (bubble' v2)
|
in (union, addVariants (f vs') union)
|
||||||
|
|
||||||
|
liftL' f vs =
|
||||||
|
let (union,vs') = mapAccumL descend' Map.empty vs
|
||||||
|
in (union, addVariants (f vs') union)
|
||||||
|
|
||||||
|
lift1L f v vs =
|
||||||
|
let (choices,v') = bubble v
|
||||||
|
(union, vs') = mapAccumL descend (unitfy choices) vs
|
||||||
|
in (union, addVariants (f v' vs') union)
|
||||||
|
|
||||||
|
lift1L' f v vs =
|
||||||
|
let (choices,v') = bubble v
|
||||||
|
(union, vs') = mapAccumL descend' (unitfy choices) vs
|
||||||
|
in (union, addVariants (f v' vs') union)
|
||||||
|
|
||||||
|
lift1L2 f v vs =
|
||||||
|
let (choices,v') = bubble v
|
||||||
|
(union, vs') = mapAccumL descend2 (unitfy choices) vs
|
||||||
|
in (union, addVariants (f v' vs') union)
|
||||||
|
|
||||||
|
lift2L f v1 v2 vs =
|
||||||
|
let (choices1,v1') = bubble v1
|
||||||
|
(choices2,v2') = bubble v2
|
||||||
|
union = mergeChoices2 choices1 choices2
|
||||||
|
(union', vs') = mapAccumL descend union vs
|
||||||
|
in (union', addVariants (f v1' v2' vs') union')
|
||||||
|
|
||||||
|
lift2 f v1 v2 =
|
||||||
|
let (choices1,v1') = bubble v1
|
||||||
|
(choices2,v2') = bubble v2
|
||||||
|
union = mergeChoices2 choices1 choices2
|
||||||
|
in (union, addVariants (f v1' v2') union)
|
||||||
|
|
||||||
|
descend union v =
|
||||||
|
let (choices,v') = bubble v
|
||||||
|
in (mergeChoices1 union choices,v')
|
||||||
|
|
||||||
|
descend' :: Map.Map Choice (BubbleVariants,Int) -> (a,Value) -> (Map.Map Choice (BubbleVariants,Int),(a,Value))
|
||||||
|
descend' union (x,v) =
|
||||||
|
let (choices,v') = bubble v
|
||||||
|
in (mergeChoices1 union choices,(x,v'))
|
||||||
|
|
||||||
|
descend2 union (v1,v2) =
|
||||||
|
let (choices1,v1') = bubble v1
|
||||||
|
(choices2,v2') = bubble v2
|
||||||
|
in (mergeChoices1 (mergeChoices1 union choices1) choices2,(v1',v2'))
|
||||||
|
|
||||||
|
descendC union (i,(v,ty)) =
|
||||||
|
let (choices,v') = bubble v
|
||||||
|
in (mergeChoices1 union choices,(i,(v',ty)))
|
||||||
|
|
||||||
|
descendR union (l,b,v) =
|
||||||
|
let (choices,v') = bubble v
|
||||||
|
in (mergeChoices1 union choices,(l,b,v'))
|
||||||
|
|
||||||
|
addVariants v = Map.foldrWithKey addVariant v
|
||||||
|
where
|
||||||
|
addVariant c (bvs,cnt) v
|
||||||
|
| cnt > 1 = VFV c $ case bvs of
|
||||||
|
BubbleFree k -> VarFree (replicate k v)
|
||||||
|
BubbleOpts nty n os -> VarOpts nty n (os <&> \(lty,l) -> (lty,l,v))
|
||||||
|
| otherwise = v
|
||||||
|
|
||||||
|
unitfy = fmap (\(n,_) -> (n,1))
|
||||||
|
mergeChoices1 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,cnt+1)) id unitfy
|
||||||
|
mergeChoices2 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,2)) unitfy unitfy
|
||||||
|
|
||||||
toPBool True = VApp poison (cPredef,cPTrue) []
|
toPBool True = VApp poison (cPredef,cPTrue) []
|
||||||
toPBool False = VApp poison (cPredef,cPFalse) []
|
toPBool False = VApp poison (cPredef,cPFalse) []
|
||||||
|
|||||||
Reference in New Issue
Block a user