From 5974263e95dafa55b02c1ca13f36ef2d56636e3b Mon Sep 17 00:00:00 2001 From: aarne Date: Tue, 9 Dec 2008 23:05:32 +0000 Subject: [PATCH] parsing in the toy editor --- src/PGF/Editor.hs | 89 ++++++++++++++++++++++++++++++++---------- src/exper/EditShell.hs | 46 ++++++++++++++++++---- 2 files changed, 107 insertions(+), 28 deletions(-) diff --git a/src/PGF/Editor.hs b/src/PGF/Editor.hs index 15ce117b8..ca268d530 100644 --- a/src/PGF/Editor.hs +++ b/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, diff --git a/src/exper/EditShell.hs b/src/exper/EditShell.hs index a50317d47..b00256478 100644 --- a/src/exper/EditShell.hs +++ b/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 + +