diff --git a/GroteTrap.cabal b/GroteTrap.cabal new file mode 100644 --- /dev/null +++ b/GroteTrap.cabal @@ -0,0 +1,25 @@ +Name: GroteTrap +Version: 0.1 +Synopsis: GroteTrap +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. + +Author: Jeroen Leeuwestein, Martijn van Steenbergen +Maintainer: martijn@van.steenbergen.nl +Copyright: Copyright (c) 2007-2008 Jeroen Leeuwesteijn and Martijn van Steenbergen + +Cabal-Version: >= 1.2 +License: BSD3 +License-file: LICENSE +Category: Language +Build-type: Simple + +Library + Build-Depends: base, QuickCheck, parsec, mtl + Exposed-Modules: Language.GroteTrap.Range + Language.GroteTrap.Trees + Language.GroteTrap.Language + Language.GroteTrap.ParseTree + Language.GroteTrap.Lexer + Language.GroteTrap.Unparse + Language.GroteTrap.Parser + Language.GroteTrap.ShowTree diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2008, Jeroen Leeuwestein and Martijn van Steenbergen +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the authors nor the + names of their contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/GroteTrap/Language.hs b/Language/GroteTrap/Language.hs new file mode 100644 --- /dev/null +++ b/Language/GroteTrap/Language.hs @@ -0,0 +1,135 @@ +-- | The Language type that is the core of GroteTrap. +module Language.GroteTrap.Language ( + + -- * Language + Language(..), + + -- * Operators + Operator(..), + Fixity1(..), Fixity2(..), + isUnary, isBinary, isNary, + findOperator, + + -- * Functions + Function(..), + findFunction, + function1, function2 + + ) where + + +------------------------------------ +-- Language +------------------------------------ + + +-- | Language connects the syntax of identifiers, numbers, operators and functions with their semantics. GroteTrap is able to derive a parser and evaluator from a Language, as well as convert between source text selections and tree selections. +data Language a = Language + { variable :: (String -> a) + , number :: (Int -> a) + , operators :: [Operator a] + , functions :: [Function a] + } + + +------------------------------------ +-- Operators +------------------------------------ + + +-- | Representation of an operator. +data Operator a + = -- | An operator expecting one operand. + Unary + { opSem1 :: a -> a + , opFixity1 :: Fixity1 + , opPrio :: Int + , opToken :: String + } + | -- | An 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 + { opSemN :: [a] -> a + , opSubranges :: Bool + , opPrio :: Int + , opToken :: String + } + + +-- | Fixity for unary operators. +data Fixity1 + = Prefix -- ^ The operator is written before its operand. + | Postfix -- ^ The operator is written after its operand. + deriving (Show, Enum, Eq) + + +-- | Fixity for infix binary operators. +data Fixity2 + = InfixL -- ^ The operator associates to the left. + | InfixR -- ^ The operator associates to the right. + deriving (Show, Enum, Eq) + + +isUnary, isBinary, isNary :: Operator a -> Bool +isUnary (Unary _ _ _ _) = True +isUnary _ = False +isBinary (Binary _ _ _ _) = True +isBinary _ = False +isNary (Nary _ _ _ _) = True +isNary _ = 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") + [o] -> return o + _ -> fail ("several operators " ++ name ++ " exist") + + +------------------------------------ +-- Functions +------------------------------------ + + +-- | Representation of a function. +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 + + +-- | 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 + + +-- | 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. +findFunction :: Monad m => String -> [Function a] -> m (Function a) +findFunction name fs = case filter ((== name) . fnName) fs of + [] -> fail ("no function named " ++ 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" +-} diff --git a/Language/GroteTrap/Lexer.hs b/Language/GroteTrap/Lexer.hs new file mode 100644 --- /dev/null +++ b/Language/GroteTrap/Lexer.hs @@ -0,0 +1,81 @@ +-- | Deriving a lexer from a 'Language'. +module Language.GroteTrap.Lexer ( + -- * Types + Token(..), + TokenPos, + + -- * Tokenizing + tokenize, isWhite + + ) where + +import Language.GroteTrap.Language +import Language.GroteTrap.Range + +import Text.ParserCombinators.Parsec + +-- | The tokenizer produces a list of tokens. +data Token + = TId String + | TInt Int + | TOperator String + | TFunction String + | TOpen + | TClose + | TComma + | TWhite Int + deriving (Eq, Show) + +-- | Whether the token is whitespace. +isWhite :: Token -> Bool +isWhite (TWhite _) = True +isWhite _ = False + +type TokenPos = (Pos, Token) + +-- | When giver a language, transforms a list of characters into a list of tokens. +tokenize :: Language a -> Parser [TokenPos] +tokenize = many . pToken + +pToken :: Language a -> Parser TokenPos +pToken lang = choice [try $ pFunction $ functions lang, pId, pInt, pOperator $ operators lang, pOpen, pClose, pComma, pWhite] + +savePos :: GenParser tok st t -> GenParser tok st (Pos, t) +savePos p = do pos <- getPos; v <- p; return (pos, v) + +getPos = do + pos <- getPosition + return $ sourceColumn pos - 1 --TODO: lines + +pId :: Parser TokenPos +pId = savePos $ do + c <- letter + cs <- many $ choice [letter, digit, char '_'] + return $ TId (c:cs) + +pInt :: Parser TokenPos +pInt = savePos $ many1 digit >>= (return . TInt . read) + +pOperator :: [Operator a] -> Parser TokenPos +pOperator = choice . map pOneOperator + +pOneOperator :: Operator a -> Parser TokenPos +pOneOperator op = savePos $ string (opToken op) >> return (TOperator (opToken op)) + +pFunction :: [Function a] -> Parser TokenPos +pFunction = choice . map pOneFunction + +pOneFunction :: Function a -> Parser TokenPos +pOneFunction fun = savePos $ string (fnName fun) >> return (TFunction (fnName fun)) + +pOpen :: Parser TokenPos +pOpen = savePos $ char '(' >> return TOpen + +pClose :: Parser TokenPos +pClose = savePos $ char ')' >> return TClose + +pComma :: Parser TokenPos +pComma = savePos $ char ',' >> return TComma + +pWhite :: Parser TokenPos +pWhite = savePos $ do spaces <- many1 space; return $ TWhite $ length spaces diff --git a/Language/GroteTrap/ParseTree.hs b/Language/GroteTrap/ParseTree.hs new file mode 100644 --- /dev/null +++ b/Language/GroteTrap/ParseTree.hs @@ -0,0 +1,87 @@ +-- | A generic parse tree. A 'ParseTree' and a 'Language' together provide enough information to fully evaluate the input sentence. +module Language.GroteTrap.ParseTree ( + + -- * Type ParseTree + ParseTree(..), + + -- * Catamorphisms + ParseTreeAlg(..), foldParseTree, + + -- * Evaluation + evaluate + + ) where + +import Language.GroteTrap.Language +import Language.GroteTrap.Range +import Language.GroteTrap.Trees + +import Data.Maybe (fromJust) + + +-- | A generic parse tree. +data ParseTree + = PId Pos String + | PInt Pos Int + | PUnary Range String ParseTree + | PBinary Range String ParseTree ParseTree + | PList Bool [Range] String [ParseTree] + | PCall Range String [ParseTree] + | PParens Range ParseTree + deriving Show + +-- | An algebra for parse trees catamorphisms. +data ParseTreeAlg a = ParseTreeAlg + { algId :: Pos -> String -> a + , algInt :: Pos -> Int -> a + , algUnary :: Range -> String -> a -> a + , algBinary :: Range -> String -> a -> a -> a + , algList :: Bool -> [Range] -> String -> [a] -> a + , algCall :: Range -> String -> [a] -> a + , algParens :: Range -> a -> a + } + +-- | Folds parse trees using an algebra. +foldParseTree :: ParseTreeAlg a -> ParseTree -> a +foldParseTree (ParseTreeAlg f1 f2 f3 f4 f5 f6 f7) = f where + f (PId a1 a2) = f1 a1 a2 + 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 (PCall a1 a2 a3) = f6 a1 a2 (map f a3) + f (PParens a1 a2) = f7 a1 (f a2) + +instance KnowsPosition 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) + 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 + PCall _ _ cs -> cs + PParens _ c -> [c] + _ -> [] + +instance Selectable ParseTree where + allowSubranges p = case p of + PList a _ _ _ -> a + _ -> 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 + ecll _ fun args = fnSem (fromJust (findFunction fun (functions lang))) args + epar _ = id diff --git a/Language/GroteTrap/Parser.hs b/Language/GroteTrap/Parser.hs new file mode 100644 --- /dev/null +++ b/Language/GroteTrap/Parser.hs @@ -0,0 +1,125 @@ +-- | Generates a full parser from a language and offers some utility functions for immediate evaluation. +module Language.GroteTrap.Parser ( + + -- * Parsing and reading + parseSentence, readParseTree, readExpression + + ) where + +import Language.GroteTrap.Lexer +import Language.GroteTrap.Language +import Language.GroteTrap.ParseTree +import Language.GroteTrap.Range + +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 or throws an error. +readParseTree :: Language a -> String -> ParseTree +readParseTree lang = resultOf . parseSentence lang + +-- | Given a language and a string, parses and evaluates the string. +readExpression :: Language a -> String -> a +readExpression lang = evaluate lang . resultOf . parseSentence 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) + +pUnit :: Language a -> GenParser TokenPos () ParseTree +pUnit lang = choice [pCall lang, pId, pInt, pParens lang] + +pId :: GenParser TokenPos () ParseTree +pId = tok f where + f (pos, TId name) = Just $ PId pos name + f _ = Nothing + +pInt :: GenParser TokenPos () ParseTree +pInt = tok f where + f (pos, TInt v) = Just $ PInt pos v + f _ = Nothing + +pCall :: Language a -> GenParser TokenPos () ParseTree +pCall lang = do + (begin,name) <- tok f + static TOpen + args <- sepBy (pTree lang) (static TComma) + (end,_) <- static TClose + return $ PCall (begin,end) name args + where f (pos, TFunction name) = Just (pos, name) + f _ = Nothing + +pParens :: Language a -> GenParser TokenPos () ParseTree +pParens lang = do + (begin,_) <- static TOpen + v <- pTree lang + (end,_) <- static TClose + return $ PParens (begin, end + 1) v + +buildOperatorTable :: [Operator a] -> P.OperatorTable TokenPos () ParseTree +buildOperatorTable = map (map buildOperator) . orderedOperators + +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 + +xFix :: Fixity1 -> GenParser t st (a -> a) -> P.Operator t st a +xFix Prefix = P.Prefix +xFix Postfix = P.Postfix + +infixX :: Fixity2 -> P.Assoc +infixX InfixL = P.AssocLeft +infixX InfixR = P.AssocRight + +orderedOperators :: [Operator a] -> [[Operator a]] +orderedOperators = groupBy equalPriority . sortBy orderPriority where + 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 + (pos, _) <- static $ TOperator token + return $ assimilate allow 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] + + +pBin :: String -> GenParser TokenPos () (ParseTree -> ParseTree -> ParseTree) +pBin token = do + (pos, _) <- static $ TOperator token + return $ PBinary (pos, pos + length token) token + +pUna :: String -> GenParser TokenPos () (ParseTree -> ParseTree) +pUna token = do + (pos, _) <- static $ TOperator token + return $ PUnary (pos, pos + length token) token + +tok :: (TokenPos -> Maybe a) -> GenParser TokenPos st a +tok = token show (newPos "tokens" 1 . fst) + +static :: Token -> GenParser TokenPos () TokenPos +static t = tok (\tp@(_,x) -> if x == t then Just tp else Nothing) diff --git a/Language/GroteTrap/Range.hs b/Language/GroteTrap/Range.hs new file mode 100644 --- /dev/null +++ b/Language/GroteTrap/Range.hs @@ -0,0 +1,65 @@ +module Language.GroteTrap.Range ( + + -- * Types + Pos, Range, KnowsPosition(..), + + -- * Utility functions + distRange, inRange, includes, unionRange, size, validRange + + ) where + +-- | A @Pos@ is a position in between two elements in a list. For example, position @0@ marks the beginning of the list, and position @length list@ marks the end of the list. There are @n + 1@ valid positions for a list of length @n@. +type Pos = Int + +-- 1 :: Pos +-- | +-- 0 1 2 3 4 5 6 7 8 9 +-- k a a s b r o o d +-- 0 1 2 3 4 5 6 7 8 9 +-- \_______/ +-- (0,4) :: Range +-- | A range's positions mark the begin and end of a sublist, respectively. +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 + -- | Yields the element's range. + range :: a -> Range + range x = (begin x, end x) + + -- | Yields the element's begin position. + begin :: a -> Pos + begin = fst . range + + -- | Yields the element's end position. + end :: a -> Pos + end = snd . range + +-- | A range's size is the number of elements it contains. +size :: Range -> Int +size (b,e) = e-b + +-- | Whether a position falls within a range, including the range's edges. +inRange :: Pos -> Range -> Bool +inRange pos (begin, end) = pos >= begin && pos <= end + +-- | @unionRange x y@ yields the smallest range z such that @x ``includes`` z@ and @y ``includes`` z@. +unionRange :: Range -> Range -> Range +unionRange = min **** max + +-- | Yields whether the second argument completely falls within the first argument. +includes :: Range -> Range -> Bool +includes r (b,e) = b `inRange` r && e `inRange` r + +-- | @distRange (b1, e1) (b2, e2)@ is defined as @|b1 - b2| + |e1 - e2|@. +distRange :: Range -> Range -> Int +distRange (b1,e1) (b2,e2) = db + de + where db = abs (b1 - b2) + de = abs (e1 - e2) + +(****) :: (a -> b -> c) -> (d -> e -> f) -> (a,d) -> (b,e) -> (c,f) +(****) fl fr (a,d) (b,e) = (fl a b, fr d e) + +-- | A range is valid if its positions are nonnegative and begin < end. +validRange :: Range -> Bool +validRange (b, e) = b >= 0 && e >= 0 && b <= e diff --git a/Language/GroteTrap/ShowTree.hs b/Language/GroteTrap/ShowTree.hs new file mode 100644 --- /dev/null +++ b/Language/GroteTrap/ShowTree.hs @@ -0,0 +1,33 @@ +module Language.GroteTrap.ShowTree (showTree, printTree) where + +import Language.GroteTrap.Range +import Language.GroteTrap.Trees +import Language.GroteTrap.Unparse + +import Data.List (intersperse) + +-- | Unparses a selectable tree type to a pretty tree representation. +showTree :: (KnowsPosition 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 = putStrLn . showTree + +showTreeAtDepth :: (KnowsPosition 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' c s = clear (range c) s + +clear :: Range -> String -> String +clear (begin, end) abc = a ++ map (const ' ') b ++ c where + (a, b, c) = splitAt3 begin end abc + +splitAt3 :: Int -> Int -> [a] -> ([a], [a], [a]) +splitAt3 x y abc = (a, b, c) where + (a, bc) = splitAt x abc + (b, c) = splitAt (y - x) bc diff --git a/Language/GroteTrap/Trees.hs b/Language/GroteTrap/Trees.hs new file mode 100644 --- /dev/null +++ b/Language/GroteTrap/Trees.hs @@ -0,0 +1,231 @@ +-- | A class for tree types and representations of selections on tree types, as well as functions for converting between text and tree selections. +module Language.GroteTrap.Trees ( + + -- * Paths and navigation + Path, root, + Nav, up, into, down, left, right, sibling, + + -- * Tree types + Tree(..), followM, follow, depth, selectDepth, flatten, + + -- * Tree selections + Selectable(..), TreeSelection, + select, allSelections, selectionToRange, rangeToSelection, posToPath, isValidRange, + + -- * Suggesting and fixing + suggest, repair + + ) where + +import Language.GroteTrap.Range + +import Data.List (sortBy, findIndex) +import Data.Maybe (isJust) +import Control.Monad.Error () + + +------------------------------------ +-- Paths and navigation +------------------------------------ + +-- | A path in a tree. Each integer denotes the selection of a child; these indices are 0-relative. +type Path = [Int] + +-- | @root@ is the empty path. +root :: Path +root = [] + +-- | Navigation transforms one path to another. +type Nav = Path -> Path + +-- | Move up to parent node. Moving up from root has no effect. +up :: Nav +up [] = [] +up path = init path + +-- | Move down into the nth child node. +into :: Int -> Nav +into i = (++[i]) + +-- | Move down into first child node. +down :: Nav +down = into 0 + +-- | Move left one sibling. +left :: Nav +left = sibling (-1) + +-- | Move right one sibling. +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 + + +------------------------------------ +-- Parents and children +------------------------------------ + +-- | Tree types. +class Tree p where + -- | Yields this tree's subtrees. + children :: p -> [p] + +-- | Breadth-first, pre-order 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 + +-- | 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") + 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) + where depths = map depth $ children t + + +-- | Yields all ancestors at the specified depth. +selectDepth :: Tree t => Int -> t -> [t] +selectDepth 0 t = [t] +selectDepth d t = concatMap (selectDepth (d - 1)) (children t) + + + +------------------------------------ +-- Tree selections +------------------------------------ + + +-- | Selection in a tree. The path indicates the left side of the selection; the int tells how many siblings to the right are included in the selection. +type TreeSelection = (Path, Int) + + +-- | 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@. + allowSubranges :: t -> Bool + + +-- | Enumerates all possible selections of a tree. +allSelections :: Selectable a => a -> [TreeSelection] +allSelections p = ([], 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 = [] + cs = children p + recurse = concat $ zipWith label cs [0 ..] + label c i = map (rt i) (allSelections c) + rt i (path, offset) = (i : path, offset) + +-- | Selects part of a tree. +select :: (Monad m, Tree t) => t -> TreeSelection -> m [t] +select t (path, offset) = (sequence . map (followM t) . take offset . 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) + + +-- | 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) + -- If the range matches that of the root, we're done. + | range p == ran = return ([], 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 + + (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)) + + else if 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 + -- caught by the previous test. + -- This also means that there are many ways + -- to select a single node: either select it + -- directly, or select all its children. + then return ([l], r - l) + + -- All other cases are bad. + else fail "text selection does not have corresponding tree selection" + + -- Either position is not contained + -- 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 + + +-- | Tells whether the text selection corresponds to a tree selection. +isValidRange :: (KnowsPosition a, Selectable a) => a -> Range -> Bool +isValidRange p = isJust . rangeToSelection p + + +------------------------------------ +-- Suggesting and fixing +------------------------------------ + + +-- | 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) + + +-- | Takes @suggest@'s first suggestion and yields its range. +repair :: (KnowsPosition a, Selectable a) => a -> Range -> Range +repair p = selectionToRange p . head . suggest p diff --git a/Language/GroteTrap/Unparse.hs b/Language/GroteTrap/Unparse.hs new file mode 100644 --- /dev/null +++ b/Language/GroteTrap/Unparse.hs @@ -0,0 +1,81 @@ +-- | The Unparse type class and its 'ParseTree' instance, as well as some text manipulation. +module Language.GroteTrap.Unparse ( + + -- * Class Unparse + Unparse(..), + + -- * Text utility functions + merge, over + + ) where + +import Language.GroteTrap.Range +import Language.GroteTrap.ParseTree + + +------------------------------------ +-- Class Unparse +------------------------------------ + + +-- | Types that are unparsable. Unparsing is like prettyprinting, except that instead of pretty source the original source code is retrieved. This means unparsing is only possible for values that were the result of an earlier parse. +class Unparse p where + unparse :: p -> String + + +------------------------------------ +-- instance Unparse ParseTree +------------------------------------ + + +instance Unparse ParseTree where + unparse = foldParseTree $ ParseTreeAlg + ( \pos name -> indent pos name ) + ( \pos value -> indent pos $ show value ) + unparseUnary + unparseBinary + unparseNary + unparseCall + unparseParens + + +indent :: Pos -> String -> String +indent n s = replicate n ' ' ++ s + + +unparseUnary :: Range -> String -> String -> String +unparseUnary (begin, _) op sub = indent begin op `over` sub + + +unparseBinary :: Range -> String -> String -> String -> String +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) + where place (begin, _) = indent begin op + + +unparseParens :: Range -> String -> String +unparseParens (begin, end) sub = indent begin "(" `over` sub `over` indent (end - 1) ")" + + +unparseCall = error "Whoops! Not implemented" + + +------------------------------------ +-- Text utility functions +------------------------------------ + + +-- | @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 :: String -> String -> String +over over' under = take n $ zipWith f (pad over') (pad under) + where f ' ' b = b + f a _ = a + pad str = str ++ repeat ' ' + n = length over' `max` length under + +-- | Merge folds many strings 'over' each other. +merge :: [String] -> String +merge = foldr over "" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain