diff options
author | Péter Diviánszky <divipp@gmail.com> | 2016-04-16 11:01:16 +0200 |
---|---|---|
committer | Péter Diviánszky <divipp@gmail.com> | 2016-04-16 11:01:16 +0200 |
commit | c7663c9f7d259b9dd6a472bb2eb0d192620cdd6a (patch) | |
tree | 28a31060e2d901a421cd02df3b3e6458dc180748 /prototypes/ShiftReducer.hs | |
parent | 72ef6e88888a83436268c42184122ab7aaeaa2cc (diff) |
work on ShiftReducer prototype
Diffstat (limited to 'prototypes/ShiftReducer.hs')
-rw-r--r-- | prototypes/ShiftReducer.hs | 27 |
1 files changed, 11 insertions, 16 deletions
diff --git a/prototypes/ShiftReducer.hs b/prototypes/ShiftReducer.hs index 178cbc6c..8da9df69 100644 --- a/prototypes/ShiftReducer.hs +++ b/prototypes/ShiftReducer.hs | |||
@@ -48,17 +48,7 @@ parens False s = s | |||
48 | 48 | ||
49 | strip (Shift _ x) = x | 49 | strip (Shift _ x) = x |
50 | 50 | ||
51 | {- | 51 | ----------------------------- |
52 | instance Applicative Shift where | ||
53 | pure = Shift (Repeat False) | ||
54 | Shift uf f <*> Shift ua a = Shift (uf <> ua) (f a) | ||
55 | |||
56 | instance Monad Shift where | ||
57 | return = pure | ||
58 | Shift ux x >>= f = up ux $ f x | ||
59 | |||
60 | --prop_UExpmonadAssoc (x :: Shift ()) (apply -> f) (apply -> g) = ((x >>= f) >>= g) == (x >>= (\x' -> f x' >>= g)) | ||
61 | -} | ||
62 | 52 | ||
63 | class GetDBUsed a where | 53 | class GetDBUsed a where |
64 | getDBUsed :: a -> DBUsed | 54 | getDBUsed :: a -> DBUsed |
@@ -145,9 +135,11 @@ upsElems = f 0 where | |||
145 | f i (Cons Nothing u) = f (i+1) u | 135 | f i (Cons Nothing u) = f (i+1) u |
146 | f i (Cons (Just a) u) = (i, a): f (i+1) u | 136 | f i (Cons (Just a) u) = (i, a): f (i+1) u |
147 | 137 | ||
138 | -- TODO: remove Eq constraint | ||
148 | expandSubsts :: (Eq a, ShiftLike a) => Stream Bool -> Substs a -> Substs a | 139 | expandSubsts :: (Eq a, ShiftLike a) => Stream Bool -> Substs a -> Substs a |
149 | expandSubsts u m = streamSubsts $ (\x -> mergeStreams u x $ Repeat Nothing) $ substsStream $ up u <$> m | 140 | expandSubsts u m = streamSubsts $ (\x -> mergeStreams u x $ Repeat Nothing) $ substsStream $ up u <$> m |
150 | 141 | ||
142 | -- TODO: remove Eq constraint | ||
151 | filterSubsts :: (Eq a, ShiftLike a) => Stream Bool -> Substs a -> Substs a | 143 | filterSubsts :: (Eq a, ShiftLike a) => Stream Bool -> Substs a -> Substs a |
152 | filterSubsts u m = streamSubsts $ filterStream (Repeat Nothing) u $ substsStream $ modDBUsed (filterDBUsed u) <$> m | 144 | filterSubsts u m = streamSubsts $ filterStream (Repeat Nothing) u $ substsStream $ modDBUsed (filterDBUsed u) <$> m |
153 | 145 | ||
@@ -230,16 +222,19 @@ transportIntoLet (Let m _) e = up (not <$> substsKeys m) e | |||
230 | ----------------------------------------------------------------- MaybeLet | 222 | ----------------------------------------------------------------- MaybeLet |
231 | 223 | ||
232 | data MaybeLet a b | 224 | data MaybeLet a b |
233 | = HasLet (Let a (Shift b)) | 225 | = HasLet (Let (Shift a) (Shift b)) |
234 | | NoLet b | 226 | | NoLet b |
235 | deriving (Show, Eq, Functor) | 227 | deriving (Show, Eq, Functor) |
236 | 228 | ||
237 | maybeLet :: (Eq a, ShiftLike a) => Shift (Let a (Shift b)) -> Shift (MaybeLet a b) | 229 | --pattern MLet :: Let -> MaybeLet a b |
230 | --pattern MLet | ||
231 | |||
232 | maybeLet :: Shift (Let (Shift a) (Shift b)) -> Shift (MaybeLet a b) | ||
238 | maybeLet l@(Shift u (Let m e)) | 233 | maybeLet l@(Shift u (Let m e)) |
239 | | Map.null m = up u $ NoLet <$> e | 234 | | Map.null m = up u $ NoLet <$> e |
240 | | otherwise = HasLet <$> l | 235 | | otherwise = HasLet <$> l |
241 | 236 | ||
242 | joinLets :: (Eq a, ShiftLike a) => MaybeLet a (MaybeLet a b) -> MaybeLet a b | 237 | joinLets :: (Eq a) => MaybeLet a (MaybeLet a b) -> MaybeLet a b |
243 | joinLets (NoLet e) = e | 238 | joinLets (NoLet e) = e |
244 | joinLets (HasLet (Let m (Shift s' (NoLet e)))) = HasLet $ Let m $ Shift s' e | 239 | joinLets (HasLet (Let m (Shift s' (NoLet e)))) = HasLet $ Let m $ Shift s' e |
245 | joinLets (HasLet (Let m (Shift s' (HasLet (Let m' e))))) | 240 | joinLets (HasLet (Let m (Shift s' (HasLet (Let m' e))))) |
@@ -249,7 +244,7 @@ joinLets (HasLet (Let m (Shift s' (HasLet (Let m' e))))) | |||
249 | 244 | ||
250 | -- TODO: test joinLets | 245 | -- TODO: test joinLets |
251 | 246 | ||
252 | instance (GetDBUsed a, GetDBUsed b) => GetDBUsed (MaybeLet a b) where | 247 | instance (GetDBUsed b) => GetDBUsed (MaybeLet a b) where |
253 | getDBUsed = \case | 248 | getDBUsed = \case |
254 | NoLet a -> getDBUsed a | 249 | NoLet a -> getDBUsed a |
255 | HasLet x -> getDBUsed x | 250 | HasLet x -> getDBUsed x |
@@ -301,7 +296,7 @@ lhs = RHS | |||
301 | EApp a b -> EApp (lhs <$> a) (lhs <$> b) | 296 | EApp a b -> EApp (lhs <$> a) (lhs <$> b) |
302 | RHS _ -> error "lhs: impossible" | 297 | RHS _ -> error "lhs: impossible" |
303 | -} | 298 | -} |
304 | type WithLet a = MaybeLet (Shift LHSExp) a | 299 | type WithLet a = MaybeLet LHSExp a |
305 | 300 | ||
306 | -------------------------------------------------------- | 301 | -------------------------------------------------------- |
307 | 302 | ||