chr-parse (empty) → 0.1.0.0
raw patch · 6 files changed
+478/−0 lines, 6 filesdep +basedep +containersdep +uulibsetup-changed
Dependencies added: base, containers, uulib
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- chr-parse.cabal +38/−0
- src/CHR/Parse.hs +208/−0
- src/CHR/Scan.hs +195/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for chr-parse++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Atze Dijkstra++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 Atze Dijkstra nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER OR CONTRIBUTORS 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ chr-parse.cabal view
@@ -0,0 +1,38 @@+-- Initial chr-parse.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: chr-parse+version: 0.1.0.0+synopsis: Parsing for chr library+description: Parsing for chr library, currently wrapping around the parsing lib from uulib and adding some utilities+homepage: https://github.com/atzedijkstra/chr+Bug-Reports: https://github.com/atzedijkstra/chr/issues+license: BSD3+license-file: LICENSE+author: Atze Dijkstra+maintainer: atzedijkstra@gmail.com+-- copyright: +category: Development+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++source-repository head+ type: git+ location: git@github.com:atzedijkstra/chr.git++library+ exposed-modules:+ CHR.Parse,+ CHR.Scan+ -- other-modules: + other-extensions:+ RankNTypes,+ CPP,+ FlexibleContexts+ build-depends:+ base >=4.9 && < 5,+ uulib >=0.9 && <0.10,+ containers >=0.5 && <0.6+ hs-source-dirs: src+ default-language: Haskell2010
+ src/CHR/Parse.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE RankNTypes, FlexibleContexts, CPP #-}++module CHR.Parse+ ( module UU.Parsing++ -- * Specific parser types+ , PlainParser+ , LayoutParser, LayoutParser2+ + -- * Top level wrappers/invocations+ , parsePlain+ , parseOffsideToResMsgs+ , parseToResMsgs+ , parseToResWith+ + , parseOffsideToResMsgsStopAtErr+ + -- * Additional parser combinators+ , pAnyFromMap, pAnyKey+ , pMaybe, pMb+ + , pDo+ + -- * Re-exports+ , position+ + -- * Dealing with Message+ , fromMessage+ )+ where++#if __GLASGOW_HASKELL__ >= 710+import Prelude hiding ( (<*>), (<*), (*>), (<$>), (<$) )+#else+#endif++import UU.Parsing+import UU.Parsing.Machine+import UU.Parsing.Offside+import UU.Scanner.Position( Position(..) )+import UU.Scanner.GenToken++import qualified Data.Map as Map+import Data.Maybe++-------------------------------------------------------------------------+-- Type(s) of parsers+-------------------------------------------------------------------------++type LayoutParser tok ep+ = forall i o p .+ (IsParser (OffsideParser i o tok p) tok,InputState i tok p, OutputState o, Position p)+ => OffsideParser i o tok p ep++type LayoutParser2 tok ep+ = forall i o p .+ (IsParser (OffsideParser i o tok p) tok,InputState i tok p, OutputState o, Position p)+ => OffsideParser i o tok p ep -> OffsideParser i o tok p ep++type PlainParser tok gp = forall p . IsParser p tok => p gp++-------------------------------------------------------------------------+-- Parsing utils+-------------------------------------------------------------------------++valFromPair :: Steps (Pair a (Pair a1 r)) s p -> Steps (a, a1) s p+valFromPair p+ = val fromPair p+ where fromPair (Pair x (Pair y _)) = (x,y)++toResMsgs :: Steps (Pair a r) s pos -> (a, [Message s pos])+toResMsgs steps+ = (r,getMsgs steps)+ where (Pair r _) = evalSteps steps++toOffsideResMsgs :: Steps (a,b) s pos -> (a, [Message s pos])+toOffsideResMsgs steps+ = r `seq` (r,getMsgs steps)+ where (r,_) = evalSteps steps++parsePlain :: (Symbol s, InputState inp s pos) + => AnaParser inp Pair s pos a + -> inp + -> Steps (a, inp) s pos+parsePlain p inp+ = valFromPair (parse p inp)++-- | Invoke parser, yielding result + errors+parseToResMsgs :: (Symbol s, InputState inp s pos) => AnaParser inp Pair s pos a -> inp -> (a,[Message s pos])+parseToResMsgs p inp+ = toResMsgs (parse p inp)++-- | Invoke parser, yielding result + errors processed with a function+parseToResWith :: (Symbol s, Show s, Eq s, InputState inp s pos) => (pos -> String -> String -> e) -> AnaParser inp Pair s pos a -> inp -> (a,[e])+parseToResWith f p inp+ = (r, map (fromMessage f) e)+ where (r,e) = toResMsgs (parse p inp)++parseOffsideToResMsgs+ :: (Symbol s, InputState i s p, Position p)+ => OffsideParser i Pair s p a -> OffsideInput i s p -> (a,[Message (OffsideSymbol s) p])+parseOffsideToResMsgs p inp+ = toOffsideResMsgs (parseOffside p inp)++-------------------------------------------------------------------------+-- Parsing, stopping at first error+-------------------------------------------------------------------------++handleEofStopAtErr input+ = case splitStateE input+ of Left' s ss -> NoMoreSteps (Pair ss ())+ Right' ss -> NoMoreSteps (Pair ss ())++parseStopAtErr+ :: (Symbol s, InputState inp s pos) + => AnaParser inp Pair s pos a + -> inp + -> Steps (Pair a (Pair inp ())) s pos+parseStopAtErr+ = parsebasic handleEofStopAtErr++parseOffsideStopAtErr+ :: (Symbol s, InputState i s p, Position p) + => OffsideParser i Pair s p a + -> OffsideInput i s p+ -> Steps (a, OffsideInput i s p) (OffsideSymbol s) p+parseOffsideStopAtErr (OP p) inp+ = valFromPair (parseStopAtErr p inp)++parseOffsideToResMsgsStopAtErr+ :: (Symbol s, InputState i s p, Position p) =>+ OffsideParser i Pair s p a+ -> OffsideInput i s p+ -> (a, [Message (OffsideSymbol s) p])+parseOffsideToResMsgsStopAtErr p inp+ = toOffsideResMsgs (parseOffsideStopAtErr p inp)++-------------------------------------------------------------------------+-- Offside for 'do' notation.+-- Problem tackled here is that both do statements and the last expr may start with 'let x=e',+-- and the presence of 'in e' following 'let x=e' indicates that it is the last statement.+-- This is a variation of pBlock1.+-------------------------------------------------------------------------++pDo :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) + => OffsideParser i o s p x + -> OffsideParser i o s p y + -> OffsideParser i o s p z + -> OffsideParser i o s p a + -> OffsideParser i o s p (Maybe last -> a)+ -> OffsideParser i o s p last + -> OffsideParser i o s p [a]+pDo open sep close pPlain pLastPrefix pLastRest+ = pOffside open close explicit implicit+ where sep' = () <$ sep+ elems s = sep0 *> es <* sep0+ where es = (:) <$> pPlain <*> esTail+ <|> (pLastPrefix+ <**> ( (\r pre -> [pre (Just r)]) <$> pLastRest+ <|> (\tl pre -> pre Nothing : tl) <$> esTail+ )+ )+ esTail = pList1 s *> es <|> pSucceed []+ sep0 = pList s+ explicit = elems sep'+ implicit = elems (sep' <|> pSeparator)++{-+pBlock1 :: (InputState i s p, OutputState o, Position p, Symbol s, Ord s) + => OffsideParser i o s p x + -> OffsideParser i o s p y + -> OffsideParser i o s p z + -> OffsideParser i o s p a + -> OffsideParser i o s p [a]+pBlock1 open sep close p = pOffside open close explicit implicit+ where sep' = () <$ sep+ elems s = pList s *> pList1Sep (pList1 s) p <* pList s+ explicit = elems sep'+ implicit = elems (sep' <|> pSeparator)++-}++-------------------------------------------------------------------------+-- Misc combinators+-------------------------------------------------------------------------++-- parse possibly present p+pMaybe :: (IsParser p s) => a1 -> (a -> a1) -> p a -> p a1+pMaybe n j p = j <$> p <|> pSucceed n++pAnyKey :: (IsParser p s) => (a1 -> p a) -> [a1] -> p a+pAnyKey pKey = foldr1 (<|>) . map pKey++pMb :: (IsParser p s) => p a -> p (Maybe a)+pMb = pMaybe Nothing Just++-- given (non-empty) key->value map, return parser for all keys returning corresponding value+pAnyFromMap :: (IsParser p s) => (k -> p a1) -> Map.Map k v -> p v+pAnyFromMap pKey m = foldr1 (<|>) [ v <$ pKey k | (k,v) <- Map.toList m ]++-------------------------------------------------------------------------+-- Dealing with error Message+-------------------------------------------------------------------------++-- | Convert from Message to anything using a function taking as String position, expected symbol and action taken respectively+fromMessage :: (Show s, Eq s) => (p -> String -> String -> x) -> Message s p -> x+fromMessage f (Msg e p a) = f p (show e) (show a)+
+ src/CHR/Scan.hs view
@@ -0,0 +1,195 @@+module CHR.Scan+ ( module UU.Scanner+ + , ScanOpts(..), defaultScanOpts++ , isNoPos, posIs1stColumn++ , InFilePos(..), infpStart, infpNone+ , infpAdvCol, infpAdvLine, infpAdv1Line, infpAdvStr++ , genTokVal, genTokTp, genTokMap++ , isLF, isStr, isStrQuote+ , isWhite, isBlack+ , isVarStart, isVarRest++ )+ where++import System.IO+import Data.Char+import Data.List+import qualified Data.Set as Set+import qualified Data.Map as Map++import CHR.Parse++import UU.Parsing+import UU.Scanner+import UU.Scanner.Position( noPos, Pos(..), Position(..) )+import UU.Scanner.GenToken++-------------------------------------------------------------------------+-- Utils for GenToken+-------------------------------------------------------------------------++genTokVal :: GenToken v t v -> v+genTokVal (ValToken _ v _) = v+genTokVal (Reserved v _) = v++genTokTp :: GenToken k t v -> Maybe t+genTokTp (ValToken t _ _) = Just t+genTokTp _ = Nothing++genTokMap :: (a->b) -> GenToken a t a -> GenToken b t b+genTokMap f (ValToken t v p) = ValToken t (f v) p+genTokMap f (Reserved k p) = Reserved (f k) p++-------------------------------------------------------------------------+-- Utils for Pos+-------------------------------------------------------------------------++isNoPos :: Pos -> Bool+isNoPos (Pos l c f) = l < 0 || c < 0++posIs1stColumn :: Pos -> Bool+posIs1stColumn p = column p == 1++-------------------------------------------------------------------------+-- InFilePos: Simplified Pos for inside a file only+-------------------------------------------------------------------------++data InFilePos+ = InFilePos { infpLine, infpColumn :: Int }+ deriving (Eq,Ord)++instance Show InFilePos where+ show (InFilePos l c) = if l < 0 || c < 0 then "" else "(" ++ show l ++ ":" ++ show c ++ ")"++infpStart :: InFilePos+infpStart = InFilePos 1 1++infpNone :: InFilePos+infpNone = InFilePos (-1) (-1)++infpAdvCol :: Int -> InFilePos -> InFilePos+infpAdvCol i p = p {infpColumn = i + infpColumn p}++infpAdvStr :: String -> InFilePos -> InFilePos+infpAdvStr s p = infpAdvCol (length s) p++infpAdvLine :: Int -> InFilePos -> InFilePos+infpAdvLine i p = p {infpLine = i + infpLine p, infpColumn = 1}++infpAdv1Line :: InFilePos -> InFilePos+infpAdv1Line = infpAdvLine 1++-------------------------------------------------------------------------+-- PP of parse errors+-------------------------------------------------------------------------++instance Position p => Position (Maybe p) where+ line = maybe (line noPos) line+ column = maybe (column noPos) column+ file = maybe (file noPos) file++instance Position (GenToken k t v) where+ line = line . position+ column = column . position+ file = file . position++{-+instance Show Pos where+ show (Pos l c f) = "(" ++ (if null f then "" else f ++ ":" ) ++ show l ++ "," ++ show c ++ ")"++instance PP Pos where+ pp (Pos l c f) = ppParens $ (if null f then empty else pp f >|< ":" ) >|< l >|< "," >|< c+-}++-------------------------------------------------------------------------+-- ScanOpts+-------------------------------------------------------------------------++{-+ScanOpts encode all possible options we ever might want to pass to a scanner used inside the EHC project.+Hence not all options are used by all scanners.+-}++data ScanOpts+ = ScanOpts+ { scoKeywordsTxt :: !(Set.Set String) -- identifiers which are keywords+ , scoPragmasTxt :: !(Map.Map String Bool) -- identifiers which are pragmas, associated with yes/no parse remainder as string literal+ , scoCommandsTxt :: !(Set.Set String) -- identifiers which are commands+ , scoKeywordsOps :: !(Set.Set String) -- operators which are keywords+ , scoKeywExtraChars :: !(Set.Set Char) -- extra chars to be used by identifiers+ , scoSpecChars :: !(Set.Set Char) -- 1 char keywords+ , scoStringDelims :: !String -- allowed delimiter for string+ , scoOpChars :: !(Set.Set Char) -- chars used for operators+ , scoSpecPairs :: !(Set.Set String) -- pairs of chars which form keywords+ , scoDollarIdent :: !Bool -- allow $ encoded identifiers+ , scoOffsideTrigs :: ![String] -- offside triggers+ , scoOffsideTrigsGE :: ![String] -- offside triggers, but allowing equal indentation (for HS 'do' notation, as per Haskell2010)+ , scoOffsideModule :: !String -- offside start of module+ , scoOffsideOpen :: !String -- offside open symbol+ , scoOffsideClose :: !String -- offside close symbol+ , scoLitmode :: !Bool -- do literal scanning+ , scoVerbOpenClose :: ![(String,String)] -- open/close pairs used for verbatim text+ , scoAllowQualified :: !Bool -- allow qualified variations, i.e. prefixing with "XXX."+ , scoAllowFloat :: !Bool -- allow float notation, i.e. numbers with dots inside+ }++defaultScanOpts :: ScanOpts+defaultScanOpts+ = ScanOpts+ { scoKeywordsTxt = Set.empty+ , scoPragmasTxt = Map.empty+ , scoCommandsTxt = Set.empty+ , scoKeywordsOps = Set.empty+ , scoKeywExtraChars = Set.empty+ , scoSpecChars = Set.empty+ , scoStringDelims = "\""+ , scoOpChars = Set.empty+ , scoSpecPairs = Set.empty+ , scoDollarIdent = False+ , scoOffsideTrigs = []+ , scoOffsideTrigsGE = []+ , scoOffsideModule = ""+ , scoOffsideOpen = ""+ , scoOffsideClose = ""+ , scoLitmode = False+ , scoVerbOpenClose = []+ , scoAllowQualified = True+ , scoAllowFloat = True+ }++-------------------------------------------------------------------------+-- Char predicates+-------------------------------------------------------------------------++isLF :: Char -> Bool+isLF = (`elem` "\n\r")++isStrQuote :: Char -> Bool+isStrQuote c = c == '"'++isStr :: Char -> Bool+isStr c = not (isStrQuote c || isLF c)++isVarStart :: Char -> Bool+isVarStart c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'++isVarRest :: Char -> Bool+isVarRest c = isVarStart c || isDigit c || c `elem` "'_"++isWhite :: Char -> Bool+isWhite = (`elem` " \t")++{-+isDig :: Char -> Bool+isDig c = c >= '0' && c <= '9'+-}++isBlack :: Char -> Bool+isBlack c = not (isWhite c || isLF c)+