diff --git a/examples/AST.hs b/examples/AST.hs --- a/examples/AST.hs +++ b/examples/AST.hs @@ -22,7 +22,7 @@ deriving Show data Decl = Var := Expr - | Seq Decl Decl + | Seq [Decl] | None deriving Show diff --git a/examples/ASTEditor.hs b/examples/ASTEditor.hs --- a/examples/ASTEditor.hs +++ b/examples/ASTEditor.hs @@ -23,13 +23,13 @@ -- | Call this to start the navigation demo. startEditor :: IO () -startEditor = +startEditor = do intro hSetBuffering stdin NoBuffering loop $ enter Expr example -example = Let (Seq (Seq ("x" := Mul (Const 6) (Const 9)) ("y" := Const (-12))) None) +example = Let (Seq ["x" := Mul (Const 6) (Const 9), "y" := Const (-12)]) (Add (EVar "x") (EVar "y")) -- | Show the current location, with the focus being highlighted in red. diff --git a/examples/ASTUse.hs b/examples/ASTUse.hs --- a/examples/ASTUse.hs +++ b/examples/ASTUse.hs @@ -58,7 +58,7 @@ :+: C Let (I Decl :*: I Expr) ) :>: Expr :+: ( C Assign (I Var :*: I Expr) - :+: C Seq (I Decl :*: I Decl) + :+: C Seq ([] :.: I Decl) :+: C None U ) :>: Decl :+: ( (K String) @@ -81,7 +81,7 @@ from Expr (Let d e) = L (Tag (R (R (R (R (C (I (I0 d) :*: I (I0 e)))))))) from Decl (x := e) = R (L (Tag (L (C (I (I0 x) :*: I (I0 e)))))) - from Decl (Seq c d) = R (L (Tag (R (L (C (I (I0 c) :*: I (I0 d))))))) + from Decl (Seq ds) = R (L (Tag (R (L (C (D (map (I . I0) ds))))))) from Decl (None) = R (L (Tag (R (R (C U))))) from Var x = R (R (Tag (K x))) @@ -93,8 +93,15 @@ to Expr (L (Tag (R (R (R (R (C (I (I0 d) :*: I (I0 e))))))))) = Let d e to Decl (R (L (Tag (L (C (I (I0 x) :*: I (I0 e))))))) = x := e - to Decl (R (L (Tag (R (L (C (I (I0 c) :*: I (I0 d)))))))) = Seq c d + to Decl (R (L (Tag (R (L (C (D ds))))))) = Seq (map (unI0 . unI) ds) to Decl (R (L (Tag (R (R (C U)))))) = None to Var (R (R (Tag (K x)))) = x +-- ** EqS instance + +instance EqS AST where + eqS Expr Expr = Just Refl + eqS Decl Decl = Just Refl + eqS Var Var = Just Refl + eqS _ _ = Nothing diff --git a/examples/ASTZipper.hs b/examples/ASTZipper.hs --- a/examples/ASTZipper.hs +++ b/examples/ASTZipper.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} module ASTZipper where diff --git a/src/Generics/MultiRec/Zipper.hs b/src/Generics/MultiRec/Zipper.hs --- a/src/Generics/MultiRec/Zipper.hs +++ b/src/Generics/MultiRec/Zipper.hs @@ -41,6 +41,7 @@ import Control.Monad import Control.Applicative import Data.Maybe +import Data.Traversable import Generics.MultiRec.Base import Generics.MultiRec.Fold @@ -64,7 +65,7 @@ -- | Abstract type of context frames. Not required for the high-level -- navigation functions. -data family Ctx f :: * -> (* -> *) -> * -> * +data family Ctx (f :: (* -> *) -> * -> *) :: * -> (* -> *) -> * -> * data instance Ctx (K a) b r ix data instance Ctx U b r ix @@ -73,6 +74,9 @@ data instance Ctx (f :*: g) b r ix = C1 (Ctx f b r ix) (g r ix) | C2 (f r ix) (Ctx g b r ix) +data instance Ctx ([] :.: g) b r ix = CCL [g r ix] (Ctx g b r ix) [g r ix] +data instance Ctx (Maybe :.: g) b r ix = CCM (Ctx g b r ix) + -- The equality constraints simulate GADTs. GHC currently -- does not allow us to use GADTs as data family instances. @@ -167,6 +171,42 @@ prev f p (C2 x c) y = prev (\p' z c' -> f p' z (C2 x c')) p c y `mplus` last (\p' z c' -> f p' z (C1 c' (fill p c y))) x + +-- For the time being, we support just [] and Maybe. I think we +-- might be able to support a whole class (Foldable). +instance (Zipper phi g) => Zipper phi ([] :.: g) where + cmapA f p (CCL pb c pe) = + CCL <$> traverse (hmapA f p) pb <*> cmapA f p c <*> traverse (hmapA f p) pe + fill p (CCL pb c pe) x = + D (reverse pb ++ fill p c x : pe) + first f (D []) = Nothing + first f (D (x : xs)) = first (\p z c -> f p z (CCL [] c xs)) x + last f (D xs) = + case reverse xs of + [] -> Nothing + y : ys -> last (\p z c -> f p z (CCL ys c [])) y + next f p (CCL pb c pe) x = + next (\p z c -> f p z (CCL pb c pe)) p c x `mplus` + case pe of + [] -> Nothing + y : ys -> first (\p' z c' -> f p' z (CCL (fill p c x : pb) c' ys)) y + prev f p (CCL pb c pe) x = + prev (\p z c -> f p z (CCL pb c pe)) p c x `mplus` + case pb of + [] -> Nothing + y : ys -> last (\p' z c' -> f p' z (CCL ys c' (fill p c x : pe))) y + +instance (Zipper phi g) => Zipper phi (Maybe :.: g) where + cmapA f p (CCM c) = + CCM <$> cmapA f p c + fill p (CCM c) x = + D (Just (fill p c x)) + first f (D Nothing) = Nothing + first f (D (Just x)) = first (\p z -> f p z . CCM) x + last f (D Nothing) = Nothing + last f (D (Just x)) = last (\p z -> f p z . CCM) x + next f p (CCM c) x = next (\p z -> f p z . CCM) p c x + prev f p (CCM c) x = prev (\p z -> f p z . CCM) p c x instance Zipper phi f => Zipper phi (f :>: xi) where cmapA f p (CTag prf c) = liftA (CTag prf) (cmapA f p c) diff --git a/zipper.cabal b/zipper.cabal --- a/zipper.cabal +++ b/zipper.cabal @@ -1,5 +1,5 @@ name: zipper -version: 0.3.1 +version: 0.4 license: BSD3 license-file: LICENSE author: Alexey Rodriguez, @@ -25,17 +25,21 @@ stability: experimental build-type: Simple -cabal-version: >= 1.2.1 -tested-with: GHC == 6.10.4, GHC == 7.0.1 +cabal-version: >= 1.6 +tested-with: GHC == 7.0.4 extra-source-files: examples/AST.hs examples/ASTUse.hs examples/ASTZipper.hs examples/ASTEditor.hs CREDITS +source-repository head + type: git + location: https://github.com/kosmikus/zipper + library hs-source-dirs: src exposed-modules: Generics.MultiRec.Zipper build-depends: base >= 3 && < 5, - multirec >= 0.4 && < 0.6 + multirec >= 0.4 && < 0.8