ideas-0.5.8: src/Text/Parsing.hs
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
-----------------------------------------------------------------------------
-- Copyright 2009, Open Universiteit Nederland. This file is distributed
-- under the terms of the GNU General Public License. For more information,
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer : bastiaan.heeren@ou.nl
-- Stability : provisional
-- Portability : portable (depends on ghc)
--
-- A simplified interface to the UU.Parsing and UU.Scanner libraries. This module
-- provides some additional functionality to determine valid sub-expressions.
--
-----------------------------------------------------------------------------
module Text.Parsing
( -- * Scaning
Scanner(..), defaultScanner, makeCharsSpecial, newlinesAsSpecial, minusAsSpecial, scan, scanWith, UU.Token
-- * Parsing
, Parser, CharParser, TokenParser, parse, Message
-- * UU parser combinators
, (<$>), (<$), (<*>), (*>), (<*), (<|>), optional, pList, pList1
, pChainl, pChainr, pChoice, pFail
-- * Subexpressions
, Ranged, Range(..), Pos(..), toRanged, fromRanged, subExpressionAt
, pKey, pSpec, pVarid, pConid, unaryOp, binaryOp, pParens, indicesToRange
, pInteger, pFraction, pString, pBracks, pCurly, pCommas, pLines
-- * Operator table (parser)
, OperatorTable, Associativity(..), pOperators
-- * Analyzing parentheses
, SyntaxError(..), fromMessage, errorToPositions
, checkParentheses, showTokenPos, tokenNoPosition
, toPosition, tokenText
) where
import qualified UU.Parsing as UU
import qualified UU.Scanner as UU
import qualified UU.Scanner.GenToken as UU
import Control.Arrow
import Common.Utils
import Data.Char
import Data.List
import Data.Maybe
----------------------------------------------------------
-- Scaning
-- | Data type to configure a scanner
data Scanner = Scanner
{ fileName :: Maybe String
, keywords :: [String]
, keywordOperators :: [String]
, specialCharacters :: String
, operatorCharacters :: String
}
-- | A default scanner configuration (using Haskell's special characters)
defaultScanner :: Scanner
defaultScanner = Scanner
{ fileName = Nothing
, keywords = []
, keywordOperators = []
, specialCharacters = "(),;[]`{}" -- Haskell's special characters
, operatorCharacters = "!#$%&*+./<=>?@\\^|-~" -- The non-special characters
}
-- | Add characters to the list of special characters (and remove these from the list of operator characters)
makeCharsSpecial :: String -> Scanner -> Scanner
makeCharsSpecial cs scanner = scanner
{ specialCharacters = specialCharacters scanner `union` cs
, operatorCharacters = operatorCharacters scanner \\ cs
}
-- Newline characters are mapped to "special" tokens
-- The current solution to deal with newlines is a hack: all characters '\n' in the input
-- are first mapped to '\001', and later the tokens are adapted
newlinesAsSpecial :: Scanner -> Scanner
newlinesAsSpecial = makeCharsSpecial [specialNewlinesChar]
specialNewlinesChar :: Char
specialNewlinesChar = chr 1
-- Minus characters are mapped to "special" tokens
-- The current solution to deal with minus is a hack: all characters '-' in the input
-- are first mapped to '\002', and later the tokens are adapted
-- (since the scanner considers -- to be comment)
minusAsSpecial :: Scanner -> Scanner
minusAsSpecial = makeCharsSpecial [specialMinusChar]
specialMinusChar :: Char
specialMinusChar = chr 2
-- | Scan an input string with the default scanner configuration
scan :: String -> [UU.Token]
scan = scanWith defaultScanner
-- | Scan an input string with the given scanner configuration
scanWith :: Scanner -> String -> [UU.Token]
scanWith scanner = post . uuScan . pre
where
-- very special characters
special = or [specialNewlines, specialMinus]
specialNewlines = specialNewlinesChar `elem` specialCharacters scanner
specialMinus = specialMinusChar `elem` specialCharacters scanner
pre = if special then map changeChar else id
post = if special then map changeToken else id
pos = UU.initPos $ fromMaybe "" (fileName scanner)
uuScan = UU.scan (keywords scanner) (keywordOperators scanner)
(specialCharacters scanner) (operatorCharacters scanner) pos
changeChar :: Char -> Char
changeChar c
| c == '\n' && specialNewlines = specialNewlinesChar
| c == '-' && specialMinus = specialMinusChar
| otherwise = c
changeToken :: UU.Token -> UU.Token
changeToken t =
case t of
UU.Reserved [c] pos
| c == specialNewlinesChar && specialNewlines -> UU.Reserved "\n" pos
| c == specialMinusChar && specialMinus -> UU.Reserved "-" pos
_ -> t
----------------------------------------------------------
-- Parsing
-- | Abstract data type for a parser, where @s@ is the symbol type, and @a@ is
-- the result type. This data type is an instance of the @IsParser@ type class
-- defined in the UU libraries.
newtype Parser s a = P { unP :: UU.AnaParser [s] UU.Pair s (Maybe s) a }
-- | A parser with characters as symbol type
type CharParser = Parser Char
-- | A parser with tokens as symbol type
type TokenParser = Parser UU.Token
instance (UU.Symbol s, Ord s) => UU.IsParser (Parser s) s where
~(P p) <*> ~(P q) = P (p UU.<*> q)
~(P p) <* ~(P q) = P (p UU.<* q)
~(P p) *> ~(P q) = P (p UU.*> q)
~(P p) <|> ~(P q) = P (p UU.<|> q)
a <$> ~(P p) = P (a UU.<$> p)
a <$ ~(P p) = P (a UU.<$ p)
pSucceed = P . UU.pSucceed
pFail = P UU.pFail
pLow = P . UU.pLow
pSym = P . UU.pSym
pRange a = P . UU.pRange a
pCostRange a b = P . UU.pCostRange a b
pCostSym a b = P . UU.pCostSym a b
getfirsts = UU.getfirsts . unP
setfirsts e = P . UU.setfirsts e . unP
getzerop = fmap P . UU.getzerop . unP
getonep = fmap P . UU.getonep . unP
type Message s = (UU.Expecting s, Maybe s)
-- Parsing an input string always returns a result and a list of error messages
parse :: UU.Symbol s => Parser s a -> [s] -> (a, [Message s])
parse (P p) input = (result, map f messages)
where
steps = UU.parse p input
result = fstPair (UU.evalSteps steps)
messages = UU.getMsgs steps
fstPair (UU.Pair a _) = a
f (UU.Msg a b _) = (a, b)
----------------------------------------------------------
-- UU parser combinators
infixl 3 <|>
infixl 4 <$>, <$, <*>, <*, *>
(<$>) :: (Ord s, UU.Symbol s) => (a -> b) -> Parser s a -> Parser s b
(<$>) = (UU.<$>)
(<$) :: (Ord s, UU.Symbol s) => a -> Parser s b -> Parser s a
(<$) = (UU.<$)
(<*>) :: (Ord s, UU.Symbol s) => Parser s (a -> b) -> Parser s a -> Parser s b
(<*>) = (UU.<*>)
(*>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s b
(*>) = (UU.*>)
(<*) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s b -> Parser s a
(<*) a = (UU.<*) a
(<|>) :: (Ord s, UU.Symbol s) => Parser s a -> Parser s a -> Parser s a
(<|>) a = (UU.<|>) a
optional :: (Ord s, UU.Symbol s) => Parser s a -> a -> Parser s a
optional = UU.opt
pList, pList1 :: (Ord s, UU.Symbol s) => Parser s a -> Parser s [a]
pList = UU.pList
pList1 = UU.pList1
pChainl, pChainr :: (Ord s, UU.Symbol s) => Parser s (a -> a -> a) -> Parser s a -> Parser s a
pChainl = UU.pChainl
pChainr = UU.pChainr
pChoice :: (Ord s, UU.Symbol s) => [Parser s a] -> Parser s a
pChoice = foldr (<|>) UU.pFail
pFail :: (Ord s, UU.Symbol s) => Parser s a
pFail = UU.pFail
----------------------------------------------------------
-- Subexpressions
-- | Abstract data type for expressions that ''know'' about the ranges of their
-- subexpressions
data Ranged a = Ranged
{ fromRanged :: a -- ^ Forget about the subexpressions
, getRange :: Range
, special :: Bool
, children :: [Ranged a]
}
instance Show a => Show (Ranged a) where
show = show . fromRanged
-- | Data type for ranges
data Range = Range
{ beginPos :: Pos
, endPos :: Pos
}
deriving (Show, Eq, Ord)
-- | Data type for positions
data Pos = Pos
{ line :: Int
, column :: Int
}
deriving (Show, Eq, Ord)
-- | A value without subexpressions
toRanged :: a -> Range -> Ranged a
toRanged a r = Ranged a r False []
-- | Given a selection (range) and a ranged term, return the location of the selected
-- subexpression (or Nothing to indicate that the selection is invalid)
subExpressionAt :: Range -> Ranged a -> Maybe [Int]
subExpressionAt r ra
| r == getRange ra = return []
| otherwise =
let f i | special ra = id
| otherwise = (i:)
in safeHead $ catMaybes
[ fmap (f i) (subExpressionAt r c) | (i, c) <- zip [0..] (children ra) ]
pKey :: String -> TokenParser Range
pKey s = toRange 1 <$> UU.pKeyPos s
pSpec :: Char -> TokenParser Range
pSpec c = toRange 1 <$> UU.pSpecPos c
pVarid, pConid :: TokenParser (String, Range)
pVarid = second (toRange 1) <$> UU.pVaridPos
pConid = second (toRange 1) <$> UU.pConidPos
unaryOp :: (a -> a) -> Range -> Ranged a -> Ranged a
unaryOp f r1 r2 = Ranged (f $ fromRanged r2) (r1 & getRange r2) False [r2]
binaryOp :: (a -> a -> a) -> Ranged a -> Ranged a -> Ranged a
binaryOp f r1 r2 = Ranged (f (fromRanged r1) (fromRanged r2)) (getRange r1 & getRange r2) False [r1, r2]
pParens :: TokenParser (Ranged a) -> TokenParser (Ranged a)
pParens p = (\p1 r p2 -> Ranged (fromRanged r) (toRange 1 p1 & toRange 1 p2) True [r]) <$> UU.pOParenPos <*> p <*> UU.pCParenPos
-- TODO: fix inconsistency with pParens
pBracks :: TokenParser a -> TokenParser a
pBracks = UU.pBracks
-- | Parse lines, separated by the newline character. The boolean argument indicates whether empy lines should
-- be accepted or not. Make sure to configure the scanner to treat newlines as special characters!
pLines :: Bool -> TokenParser a -> TokenParser [a]
pLines allowEmptyLine p = catMaybes <$> pn
where
pOne | allowEmptyLine = optional (Just <$> p) Nothing
| otherwise = Just <$> p
pn = (:) <$> pOne <*> pList (pSpec '\n' *> pOne)
-- TODO: fix inconsistency with pParens
pCurly :: TokenParser a -> TokenParser a
pCurly = UU.pCurly
pInteger :: TokenParser Integer
pInteger = (maybe 0 fromIntegral . readInt) <$> UU.pInteger
pFraction :: TokenParser Float
pFraction = read <$> UU.pFraction
pString :: TokenParser String
pString = UU.pString
pCommas :: TokenParser a -> TokenParser [a]
pCommas = UU.pCommas
-- | Helper function to translate two indices on a string to a range: the positions of a range are line-based
indicesToRange :: String -> Int -> Int -> Range
indicesToRange s i j = Range (indexToPos s a) (indexToPos s b)
where (a, b) = trimIndexPair s i j
-- local helper functions
(&) :: Range -> Range -> Range
Range p1 p2 & Range p3 p4 = Range (p1 `min` p3) (p2 `max` p4)
toPos :: UU.Pos -> Pos
toPos p = Pos (UU.line p) (UU.column p)
toRange :: Int -> UU.Pos -> Range
toRange n p = Range (toPos p) (toPos (UU.advc n p))
indexToPos :: String -> Int -> Pos
indexToPos = rec . zip [1..] . lines
where
rec [] _ = Pos 0 0
rec ((lnr, x):rest) i
| i <= len = Pos lnr (i+1)
| otherwise = rec rest (i-len-1)
where
len = length x
trimIndexPair :: String -> Int -> Int -> (Int, Int)
trimIndexPair s i j
| j < i = trimIndexPair s j i
| otherwise = (i + f sub, j - f (reverse sub))
where
sub = take (j-i) (drop i s)
f = length . takeWhile isSpace
----------------------------------------------------------
-- Operator table (parser)
-- | Type for an operator table. Operators with a low priority should appear in the front of the list.
type OperatorTable a = [(Associativity, [(String, a -> a -> a)])]
-- | Data type to express the kind of associativity. The NoMix constructor expresses that the operators
-- in the list should not be mixed, but require extra parentheses in the input
data Associativity = LeftAssociative | RightAssociative | NonAssociative | NoMix
-- | Construct a parser using an operator table
pOperators :: OperatorTable a -> TokenParser (Ranged a) -> TokenParser (Ranged a)
pOperators table p = foldr op p table
where op (a, ops) q =
case a of
-- The NoMix variant is actually hard to define efficiently. Since we should not mix operators
-- that have the same priority, we have to inspect which operator we are dealing with before
-- we can use the chain combinator.
NoMix -> let make op = flip <$> f op <*> pChainr (f op) q
in flip ($) <$> q <*> optional (pChoice $ map make ops) id
_ -> pChain a (pChoice $ map f ops) q
f (s, g) = binaryOp g <$ pKey s
-- local helper function
pChain :: (Ord s, UU.Symbol s) => Associativity -> Parser s (a -> a -> a) -> Parser s a -> Parser s a
pChain a p q = case a of
LeftAssociative -> pChainl p q
RightAssociative -> pChainr p q
NonAssociative -> flip ($) <$> q <*> p <*> q
NoMix -> pChainr p q
-----------------------------------------------------------
--- Syntax errors
data SyntaxError
= Unexpected UU.Token
| ParNotClosed UU.Token
| ParNoOpen UU.Token
| ParMismatch UU.Token UU.Token
| ErrorMessage String
instance Show SyntaxError where
show err =
case err of
Unexpected t -> "Unexpected " ++ show (tokenNoPosition t)
ParNotClosed t -> "Opening parenthesis " ++ show (tokenNoPosition t) ++ " is not closed"
ParNoOpen t -> "Closing parenthesis " ++ show (tokenNoPosition t) ++ " has no matching symbol"
ParMismatch t1 t2 -> "Opening parenthesis " ++ show (tokenNoPosition t1) ++ " is closed with " ++ show (tokenNoPosition t2)
ErrorMessage msg -> msg
fromMessage :: Message UU.Token -> SyntaxError
fromMessage (_, Just t) = Unexpected t
fromMessage _ = ErrorMessage "Syntax error"
errorToPositions :: SyntaxError -> [(Int, Int)]
errorToPositions err =
case err of
Unexpected t -> [toPosition t]
ParNotClosed t -> [toPosition t]
ParNoOpen t -> [toPosition t]
ParMismatch t1 t2 -> [toPosition t1, toPosition t2]
ErrorMessage _ -> []
-----------------------------------------------------------
--- Analyzing parentheses
tokenText :: UU.Token -> String
tokenText (UU.Reserved s _) = "symbol " ++ s
tokenText (UU.ValToken s v _) = show s ++ " " ++ v
showTokenPos :: UU.Token -> String
showTokenPos (UU.Reserved _ p) = showPosition p
showTokenPos (UU.ValToken _ _ p) = showPosition p
toPosition :: UU.Token -> (Int, Int)
toPosition (UU.Reserved _ p) = (UU.line p, UU.column p)
toPosition (UU.ValToken _ _ p) = (UU.line p, UU.column p)
showPosition :: UU.Position a => a -> String
showPosition p = show (UU.line p, UU.column p)
tokenNoPosition :: UU.Token -> UU.Token
tokenNoPosition (UU.Reserved a _) = UU.Reserved a UU.noPos
tokenNoPosition (UU.ValToken a b _) = UU.ValToken a b UU.noPos
checkParentheses :: [UU.Token] -> Maybe SyntaxError
checkParentheses = rec []
where
rec [] [] = Nothing
rec (t:_) [] = Just (ParNotClosed t)
rec stack (t:ts)
| isOpening t =
rec (t:stack) ts
| isClosing t =
case stack of
[] -> Just (ParNoOpen t)
x:xs
| match x t -> rec xs ts
| otherwise -> Just (ParMismatch x t)
| otherwise =
rec stack ts
isOpening, isClosing :: UU.Token -> Bool
isOpening (UU.Reserved ("(") _) = True
isOpening _ = False
isClosing (UU.Reserved (")") _) = True
isClosing _ = False
match :: UU.Token -> UU.Token -> Bool
match (UU.Reserved ("(") _) (UU.Reserved (")") _) = True
match _ _ = False