parsing in the toy editor

src/PGF/Editor.hs

@@ -1,8 +1,23 @@
-module PGF.Editor where
+module PGF.Editor (
+  State,       -- type-annotated possibly open tree with a position
+  Dict,        -- abstract syntax in different views
+  new,         -- :: Type  -> State
+  refine,      -- :: Dict  -> CId -> State -> State
+  replace,     -- :: Dict  -> Tree  -> State -> State
+  delete,      -- :: State -> State
+  goNextMeta,  -- :: State -> State
+  goNext,      -- :: State -> State
+  goTop,       -- :: State -> State
+  focusType,   -- :: State -> Type
+  stateTree,   -- :: State -> Tree
+  refineMenu,  -- :: Dict  -> State -> [CId]
+  pgf2dict     -- :: PGF   -> Dict
+  ) where
 
 import PGF.Data
 import PGF.CId
 import qualified Data.Map as M
+import Debug.Trace ----
 
 -- API
 
@@ -10,22 +25,37 @@ new :: Type -> State
 new (DTyp _ t _) = etree2state (uETree t)
 
 refine :: Dict -> CId -> State -> State
-refine dict f = replace (mkRefinement dict f)
+refine dict f = replaceInState (mkRefinement dict f)
 
-replace :: ETree -> State -> State
-replace t = doInState (const t)
+replace :: Dict -> Tree -> State -> State
+replace dict t = replaceInState (tree2etree dict t)
 
 delete :: State -> State
-delete s = replace (uETree (typ (tree s))) s
+delete s = replaceInState (uETree (typ (tree s))) s
 
 goNextMeta :: State -> State
-goNextMeta = untilPosition isMetaFocus goNext 
+goNextMeta s = 
+  if isComplete s then s
+  else let s1 = goNext s in if isMetaFocus s1 
+    then s1 else goNextMeta s1
+
+isComplete :: State -> Bool
+isComplete s = isc (tree s) where
+  isc t = case atom t of
+    AMeta _ -> False
+    ACon  _ -> all isc (children t)
 
 goTop :: State -> State
 goTop = navigate (const top)
 
-refineMenu :: Dict -> State -> [(CId,FType)]
-refineMenu dict s = maybe [] id $ M.lookup (focusType s) (refines dict)
+refineMenu :: Dict -> State -> [CId]
+refineMenu dict s = maybe [] (map fst) $ M.lookup (focusBType s) (refines dict)
+
+focusType :: State -> Type
+focusType s = DTyp [] (focusBType s) []
+
+stateTree :: State -> Tree
+stateTree = etree2tree . tree
 
 pgf2dict :: PGF -> Dict
 pgf2dict pgf = Dict (M.fromAscList fus) refs where
@@ -40,8 +70,17 @@ etree2tree t = case atom t of
   ACon f  -> Fun f (map etree2tree (children t))
   AMeta i -> Meta i
 
---tree2etree :: Tree -> ETree
-
+tree2etree :: Dict -> Tree -> ETree
+tree2etree dict t = case t of
+  Fun f _ -> annot (look f) t
+ where
+  annot (tys,ty) tr = case tr of 
+    Fun f trs -> ETree (ACon f)  ty [annt t tr | (t,tr) <- zip tys trs]
+    Meta i    -> ETree (AMeta i) ty []
+  annt ty tr = case tr of
+    Fun _ _ -> tree2etree dict tr
+    Meta _  -> annot ([],ty) tr
+  look f = maybe undefined id $ M.lookup f (functs dict)
 
 ---- TODO
 -- getPosition :: Language -> Int -> ETree -> Position
@@ -75,10 +114,12 @@ top :: Position
 top = []
 
 up :: Position -> Position
-up = tail
+up p = case p of
+  _:_ -> init p
+  _ -> p
 
 down :: Position -> Position
-down = (0:)
+down = (++[0])
 
 left :: Position -> Position
 left p = case p of
@@ -103,13 +144,13 @@ doInState f s = s{tree = change (position s) (tree s)} where
 subtree :: Position -> ETree -> ETree
 subtree p t = case p of
   [] -> t
-  n:ns -> subtree ns (children t !! n) 
+  n:ns -> subtree ns (children t !! n)
 
 focus :: State -> ETree
 focus s = subtree (position s) (tree s)
 
-focusType :: State -> BType
-focusType s = typ (focus s)
+focusBType :: State -> BType
+focusBType s = typ (focus s)
 
 navigate :: (Position -> Position) -> State -> State
 navigate p s = s{position = p (position s)}
@@ -128,22 +169,30 @@ untilPosition = untilFix position
 
 goNext :: State -> State
 goNext s = case focus s of
-  st | not (null (children st)) -> navigate down s 
-  _ -> navigate right (untilPosition hasYoungerSisters (navigate up) s)
+  st | not (null (children st)) -> navigate down s
+  _ -> findSister s
  where
+  findSister s = trace (show (position s)) $ case s of
+    s' | null (position s') -> s'
+    s' | hasYoungerSisters s' -> navigate right s'
+    s' -> findSister (navigate up s')
   hasYoungerSisters s = case position s of
-    n:ns -> length (children (subtree ns (tree s))) > n + 1
+    p@(_:_) -> length (children (focus (navigate up s))) > last p + 1
+    _ -> False
 
 isMetaFocus :: State -> Bool
 isMetaFocus s = case atom (focus s) of
   AMeta _ -> True
   _ -> False
 
+replaceInState :: ETree -> State -> State
+replaceInState t = doInState (const t)
+
 
 -------
 
-type BType = CId ----
-type FType = ([BType],BType) ----
+type BType = CId ----dep types
+type FType = ([BType],BType) ----dep types
 
 data Dict = Dict {
   functs  :: M.Map CId FType,

src/exper/EditShell.hs

@@ -3,6 +3,7 @@ module Main where
 import PGF.Editor
 import PGF
 
+import Data.Char
 import System (getArgs)
 
 main = do
@@ -15,25 +16,54 @@ main = do
 
 editLoop :: PGF -> Dict -> State -> IO State
 editLoop pgf dict st = do
-  putStrLn ("I want something of type " ++ prCId (focusType st))
+  putStrLn $ "I want something of type " ++ showType (focusType st) ++
+             " (0 - " ++ show (length (refineMenu dict st)-1) ++ ")"
   c   <- getLine
   st' <- interpret pgf dict st c
-  let t = etree2tree (tree st')
-  putStrLn (unlines ([
-    "Now I have",
-     showTree t] ++ 
-     linearizeAll pgf t))
   editLoop pgf dict st'
 
 interpret :: PGF -> Dict -> State -> String -> IO State
 interpret pgf dict st c = case words c of
   "r":f:_ -> do
-    return $ goNextMeta (refine dict (mkCId f) st)
+    let st' = goNext (refine dict (mkCId f) st)
+    prState pgf st'
+    return st'
+  "p":ws -> do
+    let tts = parseAll pgf (focusType st) (dropWhile (not . isSpace) c)
+    st' <- selectReplace dict (concat tts) st >>= return . goNext
+    prState pgf st'
+    return st'
   "m":_   -> do
-    putStrLn (unwords (map (prCId . fst) (refineMenu dict st)))
+    putStrLn (unwords (map prCId (refineMenu dict st)))
     return st
+  d : _ | all isDigit d -> do
+    let f = refineMenu dict st !! read d
+    let st' = goNextMeta (refine dict f st)
+    prState pgf st'
+    return st' 
+  ">":_ -> return (goNext st)
   _ -> do
     putStrLn "command not understood"
     return st
 
+prState pgf st = do
+  let t = stateTree st
+  putStrLn (unlines ([
+    "Now I have",
+     showTree t] ++ 
+     linearizeAll pgf t))
+
+-- prompt selection from list of trees, such as ambiguous choice
+selectReplace :: Dict -> [Tree] -> State -> IO State
+selectReplace dict ts st = case ts of
+  []  -> putStrLn "no results" >> return st
+  [t] -> return $ replace dict t st
+  _   -> do
+    mapM_ putStrLn $ "choose tree" : 
+      [show i ++ " : " ++ showTree t | (i,t) <- zip [0..] ts]
+    d <- getLine
+    let t = ts !! read d
+    return $ replace dict t st
+
+