packages feed

GroteTrap 0.3 → 0.4

raw patch · 12 files changed

+272/−158 lines, 12 files

Files

+ ArithmeticExample.hs view
@@ -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)
GroteTrap.cabal view
@@ -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
+ Language/GroteTrap.hs view
@@ -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
Language/GroteTrap/Language.hs view
@@ -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)
Language/GroteTrap/Lexer.hs view
@@ -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]
Language/GroteTrap/ParseTree.hs view
@@ -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
Language/GroteTrap/Parser.hs view
@@ -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)
Language/GroteTrap/Range.hs view
@@ -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)
Language/GroteTrap/ShowTree.hs view
@@ -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
Language/GroteTrap/Trees.hs view
@@ -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
Language/GroteTrap/Unparse.hs view
@@ -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
+ LogicExample.hs view
@@ -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]