diff --git a/ArithmeticExample.hs b/ArithmeticExample.hs new file mode 100644 --- /dev/null +++ b/ArithmeticExample.hs @@ -0,0 +1,28 @@ +module ArithmeticExample where + +import Language.GroteTrap + +arith :: Language Int +arith = language + { number = id + , operators = + [ Assoc sum 2 "+" + , Binary (-) InfixL 2 "-" + , Assoc product 1 "*" + , Binary div InfixL 1 "/" + , Binary (^) InfixL 0 "^" + ] + , functions = [ function1 abs "abs" ] + } + +evalArith :: String -> Int +evalArith = readExpression arith + +tree = readParseTree arith "2 + 3 * (4 + 5) * 6" +demo0 = printTree tree +demo1 = printTree $ fromError $ follow tree [1,0] +demo2 = printTree $ fromError $ follow tree [1,1] +demo3 = range $ fromError $ follow tree [1,1] +demo4 = rangeToSelection tree (4,15) :: IO TreeSelection +demo5 = rangeToSelection tree (4,14) :: IO TreeSelection +demo6 = repair tree (4,14) diff --git a/GroteTrap.cabal b/GroteTrap.cabal --- a/GroteTrap.cabal +++ b/GroteTrap.cabal @@ -1,7 +1,8 @@ Name: GroteTrap -Version: 0.3 -Synopsis: GroteTrap +Version: 0.4 +Synopsis: Parser and selection library for expression languages. Description: Allows quick definition of expression languages. You get a parser for free, as well as conversion from text selection to tree selection and back. +Homepage: http://www.haskell.org/haskellwiki/GroteTrap Author: Jeroen Leeuwestein, Martijn van Steenbergen Maintainer: martijn@van.steenbergen.nl @@ -12,14 +13,16 @@ License-file: LICENSE Category: Language Build-type: Simple +Extra-source-files: LogicExample.hs, ArithmeticExample.hs Library Build-Depends: base, QuickCheck, parsec <= 2.1.0.0, mtl - Exposed-Modules: Language.GroteTrap.Range + Exposed-Modules: Language.GroteTrap + Language.GroteTrap.Range Language.GroteTrap.Trees Language.GroteTrap.Language - Language.GroteTrap.ParseTree Language.GroteTrap.Lexer Language.GroteTrap.Unparse - Language.GroteTrap.Parser Language.GroteTrap.ShowTree + Other-Modules: Language.GroteTrap.ParseTree + Language.GroteTrap.Parser diff --git a/Language/GroteTrap.hs b/Language/GroteTrap.hs new file mode 100644 --- /dev/null +++ b/Language/GroteTrap.hs @@ -0,0 +1,28 @@ +module Language.GroteTrap ( + + -- * Re-exports + module Language.GroteTrap.Range, + module Language.GroteTrap.Trees, + module Language.GroteTrap.Language, + module Language.GroteTrap.Unparse, + module Language.GroteTrap.ShowTree, + module Language.GroteTrap.Util, + + -- * Parsing and evaluating + + -- from Parser + parseSentence, readParseTree, readExpression, + + -- from ParseTree + ParseTree, evaluate, evalRange + + ) where + +import Language.GroteTrap.Range +import Language.GroteTrap.Trees +import Language.GroteTrap.Language +import Language.GroteTrap.ParseTree +import Language.GroteTrap.Parser +import Language.GroteTrap.Unparse +import Language.GroteTrap.ShowTree +import Language.GroteTrap.Util diff --git a/Language/GroteTrap/Language.hs b/Language/GroteTrap/Language.hs --- a/Language/GroteTrap/Language.hs +++ b/Language/GroteTrap/Language.hs @@ -7,7 +7,7 @@ -- * Operators Operator(..), Fixity1(..), Fixity2(..), - isUnary, isBinary, isNary, + isUnary, isBinary, isAssoc, findOperator, -- * Functions @@ -54,17 +54,16 @@ , opPrio :: Int , opToken :: String } - | -- | An operator expecting two operands. + | -- | A non-associative operator expecting two operands. Binary { opSem2 :: a -> a -> a , opFixity2 :: Fixity2 , opPrio :: Int , opToken :: String } - | -- | An infix associative operator that chains together an arbitrary number of operands. - Nary + | -- | An infix associative operator that chains together many operands. + Assoc { opSemN :: [a] -> a - , opSubranges :: Bool , opPrio :: Int , opToken :: String } @@ -84,21 +83,21 @@ deriving (Show, Enum, Eq) -isUnary, isBinary, isNary :: Operator a -> Bool +isUnary, isBinary, isAssoc :: Operator a -> Bool isUnary (Unary _ _ _ _) = True isUnary _ = False isBinary (Binary _ _ _ _) = True isBinary _ = False -isNary (Nary _ _ _ _) = True -isNary _ = False +isAssoc (Assoc _ _ _) = True +isAssoc _ = False --- | Yields the specified operator in a monad. Fails when there are no operators with the name, or where there are several operators with the name. -findOperator :: Monad m => String -> [Operator a] -> m (Operator a) -findOperator name os = case filter ((== name) . opToken) os of - [] -> fail ("no operator " ++ name ++ " exists") +-- | @findOperator name p os@ yields the operator from @os@ that matches the predicate @p@ and has token @name@. Fails if there are no or several matching operators. +findOperator :: Monad m => String -> (Operator a -> Bool) -> [Operator a] -> m (Operator a) +findOperator name f os = case filter (\o -> f o && opToken o == name) os of + [] -> fail ("no such operator: " ++ name) [o] -> return o - _ -> fail ("several operators " ++ name ++ " exist") + _ -> fail ("duplicate operator: " ++ name) ------------------------------------ @@ -110,34 +109,22 @@ data Function a = Function { fnSem :: [a] -> a , fnName :: String - , fnArity :: Int } -- | Lifts a unary function to a 'Function'. function1 :: (a -> a) -> String -> Function a -function1 f s = Function (\[x] -> f x) s 1 +function1 f = Function (\[x] -> f x) -- | Lifts a binary function to a 'Function'. function2 :: (a -> a -> a) -> String -> Function a -function2 f s = Function (\[x, y] -> f x y) s 2 +function2 f = Function (\[x, y] -> f x y) --- | Yields the function with the specified name. If there are no functions with the name, or if there are several functions with the name, failure is returned. +-- | Yelds the function with the specified name. Fails if there are no or several matching functions. findFunction :: Monad m => String -> [Function a] -> m (Function a) findFunction name fs = case filter ((== name) . fnName) fs of - [] -> fail ("no function named " ++ name) + [] -> fail ("no such function: " ++ name) [f] -> return f - _ -> fail ("duplicate function " ++ name) - -{- -semFunction :: Function a -> [a] -> a -semFunction fun args = if arity == length args - then fnSem args - else error $ concat ["function ", name, " expects ", show arity, " ", argtext, ", but got ", show $ length args] - where arity = functionArity fun - name = functionName fun - argtext | arity == 1 = "argument" - | otherwise = "arguments" --} + _ -> fail ("duplicate function: " ++ name) diff --git a/Language/GroteTrap/Lexer.hs b/Language/GroteTrap/Lexer.hs --- a/Language/GroteTrap/Lexer.hs +++ b/Language/GroteTrap/Lexer.hs @@ -5,12 +5,13 @@ TokenPos, -- * Tokenizing - tokenize, isWhite + run, tokenize, isWhite ) where import Language.GroteTrap.Language import Language.GroteTrap.Range +import Language.GroteTrap.Util import Text.ParserCombinators.Parsec @@ -34,8 +35,8 @@ type TokenPos = (Pos, Token) -- | When given a language, transforms a list of characters into a list of tokens. -tokenize :: Language a -> Parser [TokenPos] -tokenize = many . pToken +tokenize :: Monad m => Language a -> String -> m [TokenPos] +tokenize lang = run "characters" (many $ pToken lang) pToken :: Language a -> Parser TokenPos pToken lang = choice [try $ pFunction $ functions lang, pId, pInt, pOperator $ operators lang, pOpen, pClose, pComma, pWhite] diff --git a/Language/GroteTrap/ParseTree.hs b/Language/GroteTrap/ParseTree.hs --- a/Language/GroteTrap/ParseTree.hs +++ b/Language/GroteTrap/ParseTree.hs @@ -8,7 +8,7 @@ ParseTreeAlg(..), foldParseTree, -- * Evaluation - evaluate + evaluate, evalRange ) where @@ -25,7 +25,7 @@ | PInt Pos Int | PUnary Range String ParseTree | PBinary Range String ParseTree ParseTree - | PList Bool [Range] String [ParseTree] + | PList [Range] String [ParseTree] | PCall Range String [ParseTree] | PParens Range ParseTree deriving Show @@ -36,7 +36,7 @@ , algInt :: Pos -> Int -> a , algUnary :: Range -> String -> a -> a , algBinary :: Range -> String -> a -> a -> a - , algList :: Bool -> [Range] -> String -> [a] -> a + , algList :: [Range] -> String -> [a] -> a , algCall :: Range -> String -> [a] -> a , algParens :: Range -> a -> a } @@ -48,40 +48,47 @@ f (PInt a1 a2) = f2 a1 a2 f (PUnary a1 a2 a3) = f3 a1 a2 (f a3) f (PBinary a1 a2 a3 a4) = f4 a1 a2 (f a3) (f a4) - f (PList a1 a2 a3 a4) = f5 a1 a2 a3 (map f a4) + f (PList a1 a2 a3) = f5 a1 a2 (map f a3) f (PCall a1 a2 a3) = f6 a1 a2 (map f a3) f (PParens a1 a2) = f7 a1 (f a2) -instance KnowsPosition ParseTree where +instance Ranged ParseTree where range = foldParseTree (ParseTreeAlg var int una bin list call const) where var pos name = (pos, pos + length name) int pos v = (pos, pos + (length $ show v)) una r _ c = r `unionRange` c bin _ _ (begin, _) (_, end) = (begin, end) - list _ _ _ cs = (fst $ head cs, snd $ last cs) + list _ _ cs = (fst $ head cs, snd $ last cs) call (begin,_) _ ps = (begin, snd $ last ps) instance Tree ParseTree where children p = case p of PUnary _ _ c -> [c] PBinary _ _ l r -> [l, r] - PList _ _ _ cs -> cs + PList _ _ cs -> cs PCall _ _ cs -> cs PParens _ c -> [c] _ -> [] instance Selectable ParseTree where allowSubranges p = case p of - PList a _ _ _ -> a - _ -> False + PList _ _ _ -> True + _ -> False -- | Evaluates a parse tree from a language. evaluate :: Language a -> ParseTree -> a evaluate lang = foldParseTree (ParseTreeAlg eid eint euna ebin elst ecll epar) where eid _ = variable lang eint _ = number lang - euna _ op = opSem1 $ fromJust $ findOperator op $ filter isUnary $ operators lang - ebin _ op = opSem2 $ fromJust $ findOperator op $ filter isBinary $ operators lang - elst _ _ op = opSemN $ fromJust $ findOperator op $ filter isNary $ operators lang + euna _ op = opSem1 $ fromJust $ findOperator op isUnary $ operators lang + ebin _ op = opSem2 $ fromJust $ findOperator op isBinary $ operators lang + elst _ op = opSemN $ fromJust $ findOperator op isAssoc $ operators lang ecll _ fun args = fnSem (fromJust (findFunction fun (functions lang))) args - epar _ = id + epar _ = id + +-- | Evaluates part of a parse tree. The relevant part is indicated by the range. +evalRange :: Monad m => Language a -> ParseTree -> Range -> m [a] +evalRange lang tree range = do + tsel <- rangeToSelection tree range + expr <- select tree tsel + return $ map (evaluate lang) expr diff --git a/Language/GroteTrap/Parser.hs b/Language/GroteTrap/Parser.hs --- a/Language/GroteTrap/Parser.hs +++ b/Language/GroteTrap/Parser.hs @@ -10,37 +10,29 @@ import Language.GroteTrap.Language import Language.GroteTrap.ParseTree import Language.GroteTrap.Range +import Language.GroteTrap.Util import Data.List (groupBy, sortBy) import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Pos (newPos) import qualified Text.ParserCombinators.Parsec.Expr as P -resultOf :: Show a => Either ParseError a -> a -resultOf x = case x of - Left err -> error $ "parse error at " ++ show err - Right y -> y - withEOF :: Show tok => GenParser tok st t -> GenParser tok st t withEOF p = do v <- p; eof; return v --- | Given a language and a string, yields the parse tree or a parse error. -parseSentence :: Language a -> String -> Either ParseError ParseTree -parseSentence lang = combine (tokenize lang) (withEOF $ pTree lang) +-- | Given a language and a string, yields the parse tree. +parseSentence :: Monad m => Language a -> String -> m ParseTree +parseSentence lang input = tokenize lang input >>= + run "tokens" (withEOF $ pTree lang) . filter (not . isWhite . snd) --- | Given a language and a string, yields the parse tree or throws an error. +-- | Given a language and a string, yields the parse tree or throws an exception. readParseTree :: Language a -> String -> ParseTree -readParseTree lang = resultOf . parseSentence lang +readParseTree lang = fromError . parseSentence lang -- | Given a language and a string, parses and evaluates the string. readExpression :: Language a -> String -> a readExpression lang = evaluate lang . readParseTree lang -combine :: Parser [TokenPos] -> GenParser TokenPos () c -> String -> Either ParseError c -combine p1 p2 input = case runParser p1 () "characters" input of - Left e -> Left e - Right output -> runParser p2 () "tokens" (filter (\(_, t) -> not . isWhite $ t) output) - pTree :: Language a -> GenParser TokenPos () ParseTree pTree lang = P.buildExpressionParser (buildOperatorTable $ operators lang) (pUnit lang) @@ -80,7 +72,7 @@ buildOperator :: Operator a -> P.Operator TokenPos () ParseTree buildOperator (Unary _ fix _ tok) = xFix fix (pUna tok) buildOperator (Binary _ fix _ tok) = P.Infix (pBin tok) (infixX fix) -buildOperator (Nary _ a _ tok) = P.Infix (pList a tok) P.AssocLeft +buildOperator (Assoc _ _ tok) = P.Infix (pList tok) P.AssocLeft xFix :: Fixity1 -> GenParser t st (a -> a) -> P.Operator t st a xFix Prefix = P.Prefix @@ -95,17 +87,17 @@ equalPriority a1 a2 = opPrio a1 == opPrio a2 orderPriority a1 a2 = opPrio a1 `compare` opPrio a2 -pList :: Bool -> String -> GenParser TokenPos () (ParseTree -> ParseTree -> ParseTree) -pList allow token = do +pList :: String -> GenParser TokenPos () (ParseTree -> ParseTree -> ParseTree) +pList token = do (pos, _) <- static $ TOperator token - return $ assimilate allow token (pos, pos + length token) + return $ assimilate token (pos, pos + length token) -assimilate :: Bool -> String -> Range -> ParseTree -> ParseTree -> ParseTree -assimilate allow token range pt1@(PList _ rs tok ps) pt2 - | token == tok = PList allow (rs ++ [range]) token (ps ++ [pt2]) - | otherwise = PList allow [range] token [pt1,pt2] -assimilate allow token range pt1 pt2 - = PList allow [range] token [pt1,pt2] +assimilate :: String -> Range -> ParseTree -> ParseTree -> ParseTree +assimilate token range pt1@(PList rs tok ps) pt2 + | token == tok = PList (rs ++ [range]) token (ps ++ [pt2]) + | otherwise = PList [range] token [pt1,pt2] +assimilate token range pt1 pt2 + = PList [range] token [pt1,pt2] pBin :: String -> GenParser TokenPos () (ParseTree -> ParseTree -> ParseTree) diff --git a/Language/GroteTrap/Range.hs b/Language/GroteTrap/Range.hs --- a/Language/GroteTrap/Range.hs +++ b/Language/GroteTrap/Range.hs @@ -1,7 +1,7 @@ module Language.GroteTrap.Range ( -- * Types - Pos, Range, KnowsPosition(..), + Pos, Range, Ranged(..), -- * Utility functions distRange, inRange, includes, unionRange, size, validRange @@ -22,7 +22,7 @@ type Range = (Pos, Pos) -- | Something that knows its range as sublist in a larger list. Minimal complete definition: either 'range' or both 'begin' and 'end'. -class KnowsPosition a where +class Ranged a where -- | Yields the element's range. range :: a -> Range range x = (begin x, end x) diff --git a/Language/GroteTrap/ShowTree.hs b/Language/GroteTrap/ShowTree.hs --- a/Language/GroteTrap/ShowTree.hs +++ b/Language/GroteTrap/ShowTree.hs @@ -7,20 +7,20 @@ import Data.List (intersperse) -- | Unparses a selectable tree type to a pretty tree representation. -showTree :: (KnowsPosition a, Tree a, Unparse a) => a -> String +showTree :: (Ranged a, Tree a, Unparse a) => a -> String showTree x = unlines' $ map (showTreeAtDepth x) [0..depth x - 1] -- | Writes showTree's result to stdout. -printTree :: (KnowsPosition a, Tree a, Unparse a) => a -> IO () +printTree :: (Ranged a, Tree a, Unparse a) => a -> IO () printTree = putStrLn . showTree -showTreeAtDepth :: (KnowsPosition a, Tree a, Unparse a) => a -> Int -> String +showTreeAtDepth :: (Ranged a, Tree a, Unparse a) => a -> Int -> String showTreeAtDepth p d = foldr clear' (merge $ map unparse x) (concatMap children x) where x = selectDepth d p unlines' = concat . intersperse "\n" -clear' :: (KnowsPosition a) => a -> String -> String +clear' :: (Ranged a) => a -> String -> String clear' c s = clear (range c) s clear :: Range -> String -> String diff --git a/Language/GroteTrap/Trees.hs b/Language/GroteTrap/Trees.hs --- a/Language/GroteTrap/Trees.hs +++ b/Language/GroteTrap/Trees.hs @@ -6,22 +6,24 @@ Nav, up, into, down, left, right, sibling, -- * Tree types - Tree(..), followM, follow, depth, selectDepth, flatten, + Tree(..), depth, selectDepth, flatten, follow, child, -- * Tree selections Selectable(..), TreeSelection, select, allSelections, selectionToRange, rangeToSelection, posToPath, isValidRange, -- * Suggesting and fixing - suggest, repair + suggestBy, suggest, repairBy, repair ) where import Language.GroteTrap.Range +import Language.GroteTrap.Util +import Control.Monad (liftM) import Data.List (sortBy, findIndex) import Data.Maybe (isJust) -import Control.Monad.Error () +import Data.Ord (comparing) ------------------------------------ @@ -43,9 +45,9 @@ up [] = [] up path = init path --- | Move down into the nth child node. +-- | Move down into the nth child node. If @n@ is negative, the leftmost child is selected. into :: Int -> Nav -into i = (++[i]) +into i = (++ [i `max` 0]) -- | Move down into first child node. down :: Nav @@ -59,13 +61,11 @@ right :: Nav right = sibling 1 --- | Move @n@ siblings (@n@ can be negative). -sibling :: Int -> Nav -sibling 0 p = p -- because sibling 0 [] == [] -sibling d p = if newindex < 0 then p else into newindex parent - where index = last p - newindex = index + d - parent = up p +-- | Move @n@ siblings to the right. @n@ can be negative. If the new child index becomes negative, the leftmost child is selected. +sibling :: Int -> Nav +sibling 0 [] = [] +sibling _ [] = error "the root has no siblings" +sibling d p = into (last p + d) (up p) ------------------------------------ @@ -77,42 +77,30 @@ -- | Yields this tree's subtrees. children :: p -> [p] --- | Breadth-first, pre-order traversal. +-- | Pre-order depth-first traversal. flatten :: Tree t => t -> [t] flatten t = t : concatMap flatten (children t) -- | Follows a path in a tree, returning the result in a monad. -followM :: (Monad m, Tree t) => t -> Path -> m t -followM parent [] = return parent -followM parent (t:ts) = do - c <- childM parent t - followM c ts +follow :: (Monad m, Tree t) => t -> Path -> m t +follow parent [] = return parent +follow parent (t:ts) = do + c <- child parent t + follow c ts -- | Moves down into a child. -childM :: (Monad m, Tree p) => p -> Int -> m p -childM t i = if i >= 0 && i < length cs - then return (cs !! i) - else fail ("child " ++ show i ++ " does not exist") +child :: (Monad m, Tree t) => t -> Int -> m t +child t i + | i >= 0 && i < length cs = return (cs !! i) + | otherwise = fail ("child " ++ show i ++ " does not exist") where cs = children t --- | Follows a path in a tree. -follow :: Tree t => t -> Path -> t -follow t = fromError . followM t -fromError :: Either String a -> a -fromError = either error id - -{- -indexIn :: (Eq p, Parent p) => p -> p -> Maybe Int -indexIn child = elemIndex child . children --} - - -- | Yields the depth of the tree. depth :: Tree t => t -> Int depth t | null depths = 1 - | otherwise = 1 + maximum (map depth $ children t) + | otherwise = 1 + (maximum . map depth . children) t where depths = map depth $ children t @@ -134,20 +122,21 @@ -- | Selectable trees. class Tree t => Selectable t where - -- | Tells whether complete subranges of children may be selected in this tree. If not, valid TreeSelections in this tree always have a second element @0@. + -- | Tells whether complete subranges of children may be selected in this tree node. If not, valid TreeSelections in this tree always have a second element @0@. allowSubranges :: t -> Bool -- | Enumerates all possible selections of a tree. allSelections :: Selectable a => a -> [TreeSelection] -allSelections p = ([], 0) : subranges ++ recurse where +allSelections p = (root, 0) : subranges ++ recurse where subranges - | allowSubranges p = [ ([from], to - from) - | from <- [0 .. length cs - 2] - , to <- [from + 1 .. length cs - 1] - , from > 0 || to < length cs - 1 - ] - | otherwise = [] + | allowSubranges p = + [ ([from], to - from) + | from <- [0 .. length cs - 2] + , to <- [from + 1 .. length cs - 1] + , from > 0 || to < length cs - 1 + ] + | otherwise = [] cs = children p recurse = concat $ zipWith label cs [0 ..] label c i = map (rt i) (allSelections c) @@ -155,35 +144,37 @@ -- | Selects part of a tree. select :: (Monad m, Tree t) => t -> TreeSelection -> m [t] -select t (path, offset) = (sequence . map (followM t) . take (offset + 1) . iterate right) path +select t (path, offset) = (sequence . map (follow t) . take (offset + 1) . iterate right) path -- | Computes the range of a valid selection. -selectionToRange :: (Tree a, KnowsPosition a) => a -> TreeSelection -> Range -selectionToRange parent (path, offset) = (from, to) where - from = begin $ follow parent path - to = end $ follow parent (sibling offset path) +selectionToRange :: (Monad m, Tree a, Ranged a) => a -> TreeSelection -> m Range +selectionToRange parent (path, offset) = do + from <- follow parent path + to <- follow parent (sibling offset path) + return (begin from, end to) -- | Converts a specified range to a corresponding selection and returns it in a monad. -rangeToSelection :: (Tree a, KnowsPosition a, Monad m) => a -> Range -> m TreeSelection -rangeToSelection p ran@(b, e) +rangeToSelection :: (Monad m, Selectable a, Ranged a) => a -> Range -> m TreeSelection +rangeToSelection p (b, e) -- If the range matches that of the root, we're done. - | range p == ran = return ([], 0) + | range p == (b, e) = + return (root, 0) | otherwise = -- Find the children whose ranges contain b and e. - case ( findIndex (\c -> b `inRange` range c) cs - , findIndex (\c -> e `inRange` range c) cs) of + let cs = children p + ri pos = findIndex (inRange pos . range) cs + in case (ri b, ri e) of (Just l, Just r) -> if l == r -- b and e are contained by the same child! - -- Recurse into child. - then rangeToSelection (cs !! l) ran - -- ... and prepend child index, of course. - >>= (\(path, offset) -> return (l : path, offset)) + -- Recurse into child and prepend child index. + then liftM (\(path, offset) -> (l : path, offset)) $ + rangeToSelection (cs !! l) (b, e) - else if begin (cs !! l) == b && end (cs !! r) == e + else if allowSubranges p && begin (cs !! l) == b && end (cs !! r) == e -- b is the beginning of l, and e is the end -- of r: a selection of a range of children. -- Note that r - l > 0; else it would've been @@ -200,18 +191,18 @@ -- within any child. Can't be valid. _ -> fail "text selection does not have corresponding tree selection" - where cs = children p - -- | Returns the path to the deepest descendant whose range contains the specified position. -posToPath :: (Tree a, KnowsPosition a) => a -> Pos -> Path -posToPath p pos = case break (\c -> pos `inRange` range c) (children p) of - (_, []) -> [] - (no, c:_) -> length no : posToPath c pos +posToPath :: (Monad m, Tree a, Ranged a) => a -> Pos -> m Path +posToPath p pos = case break (inRange pos . range) (children p) of + (_, []) -> if pos `inRange` range p + then return root + else fail ("tree does not contain position " ++ show pos) + (no, c:_) -> liftM (length no :) (posToPath c pos) -- | Tells whether the text selection corresponds to a tree selection. -isValidRange :: (KnowsPosition a, Selectable a) => a -> Range -> Bool +isValidRange :: (Ranged a, Selectable a) => a -> Range -> Bool isValidRange p = isJust . rangeToSelection p @@ -221,11 +212,18 @@ -- | Yields all possible selections, ordered by distance to the specified range, closest first. -suggest :: (Selectable a, KnowsPosition a) => a -> Range -> [TreeSelection] -suggest p r = sortBy distance $ allSelections p where - distance s1 s2 = (selectionToRange p s1 `distRange` r) `compare` (selectionToRange p s2 `distRange` r) +suggestBy :: (Selectable a, Ranged a) => (Range -> Range -> Int) -> a -> Range -> [TreeSelection] +suggestBy cost p r = sortBy (comparing distance) (allSelections p) where + distance = cost r . fromError . selectionToRange p +-- | @suggest@ uses 'distRange' as cost function. +suggest :: (Selectable a, Ranged a) => a -> Range -> [TreeSelection] +suggest = suggestBy distRange --- | Takes @suggest@'s first suggestion and yields its range. -repair :: (KnowsPosition a, Selectable a) => a -> Range -> Range -repair p = selectionToRange p . head . suggest p +-- | Takes @suggestBy@'s first suggestion and yields its range. +repairBy :: (Ranged a, Selectable a) => (Range -> Range -> Int) -> a -> Range -> Range +repairBy cost p = fromError . selectionToRange p . head . suggestBy cost p + +-- | @repair@ uses 'distRange' as cost function. +repair :: (Ranged a, Selectable a) => a -> Range -> Range +repair = repairBy distRange diff --git a/Language/GroteTrap/Unparse.hs b/Language/GroteTrap/Unparse.hs --- a/Language/GroteTrap/Unparse.hs +++ b/Language/GroteTrap/Unparse.hs @@ -51,8 +51,8 @@ unparseBinary (begin, _) op left right = left `over` indent begin op `over` right -unparseNary :: Bool -> [Range] -> String -> [String] -> String -unparseNary _ ranges op children = foldl over "" children `over` foldl over "" (map place ranges) +unparseNary :: [Range] -> String -> [String] -> String +unparseNary ranges op children = foldl over "" children `over` foldl over "" (map place ranges) where place (begin, _) = indent begin op @@ -68,13 +68,13 @@ ------------------------------------ --- | @over over' under@ places @over'@ over @under@. The resulting string has the same characters as @over'@ does, except where @over'@ contains spaces; at those positions, the character from @under@ shows. If @under@ is longer than @over'@, @over'@ is padded with enough spaces to show all rest of @under@. +-- | @over upper lower@ places @upper@ over @lower@. The resulting string has the same characters as @upper@ does, except where @upper@ contains spaces; at those positions, the character from @lower@ shows. If @lower@ is longer than @upper@, @upper@ is padded with enough spaces to show all rest of @lower@. over :: String -> String -> String -over over' under = take n $ zipWith f (pad over') (pad under) +over upper lower = take n $ zipWith f (pad upper) (pad lower) where f ' ' b = b f a _ = a pad str = str ++ repeat ' ' - n = length over' `max` length under + n = length upper `max` length lower -- | Merge folds many strings 'over' each other. merge :: [String] -> String diff --git a/LogicExample.hs b/LogicExample.hs new file mode 100644 --- /dev/null +++ b/LogicExample.hs @@ -0,0 +1,70 @@ +module LogicExample where + +import Language.GroteTrap + +import Data.Set hiding (map) + + +-- Logic data structure. + +data Logic + = Var String + | Or [Logic] + | And [Logic] + | Impl Logic Logic + | Not Logic + deriving (Show, Eq) + +type LogicAlg a = + ( String -> a + , [a] -> a + , [a] -> a + , a -> a -> a + , a -> a + ) + +foldLogic :: LogicAlg a -> Logic -> a +foldLogic (f1, f2, f3, f4, f5) = f where + f (Var a1 ) = f1 a1 + f (Or a1) = f2 (map f a1) + f (And a1) = f3 (map f a1) + f (Impl a1 a2) = f4 (f a1) (f a2) + f (Not a1 ) = f5 (f a1) + + +-- Language definition. + +logicLanguage :: Language Logic +logicLanguage = language + { variable = Var + , operators = + [ Unary Not Prefix 0 "!" + , Assoc And 1 "&&" + , Assoc Or 2 "||" + , Binary Impl InfixR 3 "->" + ] + } + + +-- Evaluation. + +type Environment = Set String + +evalLogic :: Environment -> Logic -> Bool +evalLogic env = foldLogic ((`member` env), or, and, (||) . not, not) + +readLogic :: Environment -> String -> Bool +readLogic env = evalLogic env . readExpression logicLanguage + +-- Examples + +appie :: ParseTree +appie = readParseTree logicLanguage "piet && klaas && maartje -> supermarkt" + +demo1 = appie +demo2 = unparse $ appie +demo9 = evaluate logicLanguage appie +demo3 = printTree $ appie +demo4 = fromError $ follow appie root +demo5 = fromError $ follow appie [0] +demo6 = range $ fromError $ follow appie [0]