Skip to content

Commit 79f05a6

Browse files
doaitsedoaitse
authored
Initial version from hackage
Moving info into the UU-ComputerScience repository
1 parent ff2b44c commit 79f05a6

13 files changed

+2182
-0
lines changed

‎LICENSE

+22
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
Copyright (c) 2010, SD Swierstra
2+
All rights reserved.
3+
4+
The MIT License
5+
6+
Permission is hereby granted, free of charge, to any person obtaining a copy
7+
of this software and associated documentation files (the "Software"), to deal
8+
in the Software without restriction, including without limitation the rights
9+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10+
copies of the Software, and to permit persons to whom the Software is
11+
furnished to do so, subject to the following conditions:
12+
13+
The above copyright notice and this permission notice shall be included in
14+
all copies or substantial portions of the Software.
15+
16+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
22+
THE SOFTWARE.

‎Setup.hs

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
#!/usr/bin/env runhaskell
2+
import Distribution.Simple
3+
main :: IO ()
4+
main = defaultMain

‎src/Text/ParserCombinators/UU.hs

+29
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,29 @@
1+
-- | The non-exported modules in "Text.ParserCombinators.UU.Demo" contain a list of examples of how to use the main functionality of this library which demonstrates:
2+
--
3+
-- * how to write basic parsers
4+
--
5+
-- * how to to write ambiguous parsers
6+
--
7+
-- * how error correction works
8+
--
9+
-- * how to fine-tune your parsers to get rid of ambiguities
10+
--
11+
-- * how to use the monadic interface
12+
--
13+
-- * what kind of error messages you can expect if you write erroneous parsers
14+
--
15+
-- * how to use the permutating/merging parsers
16+
--
17+
-- * to see the parsers in action load the module "Text.ParserCombinators.UU.Demo.Examples" or "Text.ParserCombinators.UU.Demo.MergeAndPermute" in @ghci@ and type @show_demos@, while looking at the corresponding code
18+
--
19+
20+
module Text.ParserCombinators.UU ( module Text.ParserCombinators.UU.Core
21+
, module Text.ParserCombinators.UU.Derived
22+
) where
23+
import Text.ParserCombinators.UU.Core
24+
import Text.ParserCombinators.UU.Derived
25+
26+
27+
28+
29+

‎src/Text/ParserCombinators/UU/BasicInstances.hs

+243
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,243 @@
1+
{-# LANGUAGE RankNTypes,
2+
GADTs,
3+
MultiParamTypeClasses,
4+
FunctionalDependencies,
5+
FlexibleInstances,
6+
FlexibleContexts,
7+
UndecidableInstances,
8+
NoMonomorphismRestriction,
9+
TypeSynonymInstances,
10+
ScopedTypeVariables,
11+
TypeOperators #-}
12+
13+
-- | This module contains basic instances for the class interface described in the "Text.ParserCombinators.UU.Core" module.
14+
-- It demonstates how to construct and maintain a state during parsing. In the state we store error messages,
15+
-- positional information and the actual input that is being parsed.
16+
-- Unless you have very specific wishes the module can be used as such.
17+
-- Since we make use of the "Data.ListLike" interface a wide variety of input structures can be handled.
18+
19+
module Text.ParserCombinators.UU.BasicInstances(
20+
-- * Data Types
21+
Error (..),
22+
Str (..),
23+
Insertion (..),
24+
LineCol (..),
25+
LineColPos (..),
26+
-- * Types
27+
Parser,
28+
ParserTrafo,
29+
-- * Classes
30+
IsLocationUpdatedBy,
31+
-- * Functions
32+
createStr,
33+
show_expecting,
34+
pSatisfy,
35+
pRangeInsert,
36+
pRange,
37+
pSymInsert,
38+
pSym,
39+
pToken,
40+
pTokenCost,
41+
pMunch,
42+
pMunchL
43+
) where
44+
import Text.ParserCombinators.UU.Core
45+
import Data.Maybe
46+
import Data.Word
47+
-- import Debug.Trace
48+
import qualified Data.ListLike as LL
49+
50+
-- * `Error`
51+
-- |The data type `Error` describes the various kinds of errors which can be generated by the instances in this module
52+
data Error pos = Inserted String pos Strings
53+
-- ^ @String@ was inserted at @pos@-ition, where we expected @Strings@
54+
| Deleted String pos Strings
55+
-- ^ @String@ was deleted at @pos@-ition, where we expected @Strings@
56+
| Replaced String String pos Strings
57+
-- ^ for future use
58+
| DeletedAtEnd String
59+
-- ^ the unconsumed part of the input was deleted
60+
61+
instance (Show pos) => Show (Error pos) where
62+
show (Inserted s pos expecting) = "-- Inserted " ++ s ++ show_expecting pos expecting
63+
show (Deleted t pos expecting) = "-- Deleted " ++ t ++ show_expecting pos expecting
64+
show (Replaced old new pos expecting) = "-- Replaced " ++ old ++ " by "++ new ++ show_expecting pos expecting
65+
show (DeletedAtEnd t) = "-- The token " ++ t ++ " was not consumed by the parsing process."
66+
67+
68+
69+
show_expecting :: Show pos => pos -> [String] -> String
70+
show_expecting pos [a] = " at position " ++ show pos ++ " expecting " ++ a
71+
show_expecting pos (a:as) = " at position " ++ show pos ++
72+
" expecting one of [" ++ a ++ concat (map (", " ++) as) ++ "]"
73+
show_expecting pos [] = " expecting nothing"
74+
75+
-- * The Stream data type
76+
-- | The data type `Str` holds the input data to be parsed, the current location, the error messages generated
77+
-- and whether it is ok to delete elements from the input. Since an insert/delete action is
78+
-- the same as a delete/insert action we try to avoid the first one.
79+
-- So: no deletes after an insert.
80+
81+
data Str a s loc = Str { -- | the unconsumed part of the input
82+
input :: s,
83+
-- | the accumulated error messages
84+
msgs :: [Error loc],
85+
-- | the current input position
86+
pos :: loc,
87+
-- | we want to avoid deletions after insertions
88+
deleteOk :: !Bool
89+
}
90+
91+
-- | A `Parser` is a parser that is prepared to accept "Data.Listlike" input; hence we can deal with @String@'s, @ByteString@'s, etc.
92+
type Parser a = forall loc state . (IsLocationUpdatedBy loc Char, LL.ListLike state Char) => P (Str Char state loc) a
93+
94+
-- | A @`ParserTrafo` a b@ maps a @`Parser` a@ onto a @`Parser` b@.
95+
type ParserTrafo a b = forall loc state . (IsLocationUpdatedBy loc Char, LL.ListLike state Char) => P (Str Char state loc) a -> P (Str Char state loc) b
96+
97+
-- | `createStr` initialises the input stream with the input data and the initial position. There are no error messages yet.
98+
createStr :: LL.ListLike s a => loc -> s -> Str a s loc
99+
createStr beginpos ls = Str ls [] beginpos True
100+
101+
102+
-- The first parameter is the current position, and the second parameter the part which has been removed from the input.
103+
instance IsLocationUpdatedBy Int Char where
104+
advance pos _ = pos + 1
105+
106+
instance IsLocationUpdatedBy Int Word8 where
107+
advance pos _ = pos + 1
108+
109+
data LineCol = LineCol !Int !Int deriving Show
110+
instance IsLocationUpdatedBy LineCol Char where
111+
advance (LineCol line pos) c = case c of
112+
'\n' -> LineCol (line+1) 0
113+
'\t' -> LineCol line ( pos + 8 - (pos-1) `mod` 8)
114+
_ -> LineCol line (pos + 1)
115+
116+
data LineColPos = LineColPos !Int !Int !Int deriving Show
117+
instance IsLocationUpdatedBy LineColPos Char where
118+
advance (LineColPos line pos abs) c = case c of
119+
'\n' -> LineColPos (line+1) 0 (abs + 1)
120+
'\t' -> LineColPos line (pos + 8 - (pos-1) `mod` 8) (abs + 1)
121+
_ -> LineColPos line (pos + 1) (abs + 1)
122+
123+
instance IsLocationUpdatedBy loc a => IsLocationUpdatedBy loc [a] where
124+
advance = foldl advance
125+
126+
instance (Show a, LL.ListLike s a) => Eof (Str a s loc) where
127+
eof (Str i _ _ _ ) = LL.null i
128+
deleteAtEnd (Str s msgs pos ok ) | LL.null s = Nothing
129+
| otherwise = Just (5, Str (LL.tail s) (msgs ++ [DeletedAtEnd (show (LL.head s))]) pos ok)
130+
131+
132+
instance StoresErrors (Str a s loc) (Error loc) where
133+
getErrors (Str inp msgs pos ok ) = (msgs, Str inp [] pos ok)
134+
135+
instance HasPosition (Str a s loc) loc where
136+
getPos (Str inp msgs pos ok ) = pos
137+
138+
-- | the @String@ describes what is being inserted, the @a@ parameter the value which is to be inserted and the @cost@ the prices to be paid.
139+
data Insertion a = Insertion String a Cost
140+
141+
-- | `pSatisfy` describes and elementary parsing step. Its first parameter check whether the head element of the input can be recognised,
142+
-- and the second parameter how to proceed in case an element recognised by this parser is absent,
143+
-- and parsing may proceed by pretending such an element was present in the input anayway.
144+
pSatisfy :: forall loc state a .((Show a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => (a -> Bool) -> (Insertion a) -> P (Str a state loc) a)
145+
pSatisfy p (Insertion msg a cost) = pSymExt splitState (Succ (Zero)) Nothing
146+
where splitState :: forall r. ((a -> (Str a state loc) -> Steps r) -> (Str a state loc) -> Steps r)
147+
splitState k (Str tts msgs pos del_ok)
148+
= show_attempt ("Try Predicate: " ++ msg ++ " at position " ++ show pos ++ "\n") (
149+
let ins exp = (cost, k a (Str tts (msgs ++ [Inserted (show a) pos exp]) pos False))
150+
in if LL.null tts
151+
then Fail [msg] [ins]
152+
else let t = LL.head tts
153+
ts = LL.tail tts
154+
del exp = (4, splitState k (Str ts (msgs ++ [Deleted (show t) pos exp]) (advance pos t) True ))
155+
in if p t
156+
then show_symbol ("Accepting symbol: " ++ show t ++ " at position: " ++ show pos ++"\n")
157+
(Step 1 (k t (Str ts msgs (advance pos t) True)))
158+
else Fail [msg] (ins: if del_ok then [del] else [])
159+
)
160+
-- | `pRangeInsert` recognises an element between a lower and an upper bound. Furthermore it can be specified what element
161+
-- is to be inserted in case such an element is not at the head of the input.
162+
pRangeInsert :: (Ord a, Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => (a, a) -> Insertion a -> P (Str a state loc) a
163+
pRangeInsert (low, high) = pSatisfy (\ t -> low <= t && t <= high)
164+
165+
-- | `pRange` uses the information from the bounds to compute the `Insertion` information.
166+
pRange :: (Ord a, Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => (a, a) -> P (Str a state loc) a
167+
pRange lh@(low, high) = pRangeInsert lh (Insertion (show low ++ ".." ++ show high) low 5)
168+
169+
170+
-- | `pSymInsert` recognises a specific element. Furthermore it can be specified what element
171+
-- is to be inserted in case such an element is not at the head of the input.
172+
pSymInsert :: (Eq a,Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => a -> Insertion a -> P (Str a state loc) a
173+
pSymInsert t = pSatisfy (==t)
174+
175+
-- | `pSym` recognises a specific element. Furthermore it can be specified what element. Information about `Insertion` is derived from the parameter.
176+
-- is to be inserted in case such an element is not at the head of the input.
177+
pSym :: (Eq a,Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => a -> P (Str a state loc) a
178+
pSym t = pSymInsert t (Insertion (show t) t 5)
179+
180+
-- | `pMunchL` recognises the longest prefix of the input for which the passed predicate holds. The message parameter is used when tracing has been switched on.
181+
pMunchL :: forall loc state a .((Show a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => (a -> Bool) -> String -> P (Str a state loc) [a])
182+
pMunchL p msg = pSymExt splitState Zero Nothing
183+
where splitState :: forall r. (([a] -> (Str a state loc) -> Steps r) -> (Str a state loc) -> Steps r)
184+
splitState k inp@(Str tts msgs pos del_ok)
185+
= show_attempt ("Try Munch: " ++ msg ++ "\n") (
186+
let (fmunch, rest) = LL.span p tts
187+
munched = LL.toList fmunch
188+
l = length munched
189+
in if l > 0 then show_munch ("Accepting munch: " ++ msg ++ " " ++ show munched ++ show pos ++ "\n")
190+
(Step l (k munched (Str rest msgs (advance pos munched) (l>0 || del_ok))))
191+
else show_munch ("Accepting munch: " ++ msg ++ " as emtty munch " ++ show pos ++ "\n") (k [] inp)
192+
)
193+
194+
-- | `pMunch` recognises the longest prefix of the input for which the passed predicate holds.
195+
pMunch :: forall loc state a .((Show a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => (a -> Bool) -> P (Str a state loc) [a])
196+
pMunch p = pMunchL p ""
197+
198+
-- | `pTokenCost` succeeds if its parameter is a prefix of the input.
199+
pTokenCost :: forall loc state a .((Show a, Eq a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => [a] -> Int -> P (Str a state loc) [a])
200+
pTokenCost as cost =
201+
if null as then error "Module: BasicInstances, function: pTokenCost; call with empty token"
202+
else pSymExt splitState (nat_length as) Nothing
203+
where tas :: state
204+
tas = LL.fromList as
205+
nat_length [] = Zero
206+
nat_length (_:as) = Succ (nat_length as)
207+
l = length as
208+
msg = show as
209+
splitState :: forall r. (([a] -> (Str a state loc) -> Steps r) -> (Str a state loc) -> Steps r)
210+
splitState k inp@(Str tts msgs pos del_ok)
211+
= show_attempt ("Try Token: " ++ show as ++ "\n") (
212+
if LL.isPrefixOf tas tts
213+
then show_tokens ("Accepting token: " ++ show as ++"\n")
214+
(Step l (k as (Str (LL.drop l tts) msgs (advance pos as) True)))
215+
else let ins exp = (cost, k as (Str tts (msgs ++ [Inserted msg pos exp]) pos False))
216+
in if LL.null tts
217+
then Fail [msg] [ins]
218+
else let t = LL.head tts
219+
ts = LL.tail tts
220+
del exp = (5, splitState k
221+
(Str ts (msgs ++ [Deleted (show t) pos exp])
222+
(advance pos t) True))
223+
in Fail [msg] (ins: if del_ok then [del] else [])
224+
225+
)
226+
pToken :: forall loc state a .((Show a, Eq a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => [a] -> P (Str a state loc) [a])
227+
pToken as = pTokenCost as 10
228+
229+
{-# INLINE show_tokens #-}
230+
231+
show_tokens :: String -> b -> b
232+
show_tokens m v = {- trace m -} v
233+
234+
{-# INLINE show_munch #-}
235+
show_munch :: String -> b -> b
236+
show_munch m v = {- trace m -} v
237+
238+
{-# INLINE show_symbol #-}
239+
show_symbol :: String -> b -> b
240+
show_symbol m v = {- trace m -} v
241+
-- show_symbol m v = trace m v
242+
{-# INLINE show_attempt #-}
243+
show_attempt m v = {- trace m -} v

0 commit comments

Comments
 (0)