]> Git — Sourcephile - haskell/symantic.git/blob - symantic-lib/test/Testing/Megaparsec.hs
Update to lastest symantic-document
[haskell/symantic.git] / symantic-lib / test / Testing / Megaparsec.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE UndecidableInstances #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 -- | Symantic instances for Megaparsec
5 module Testing.Megaparsec where
6
7 import Control.Applicative (Applicative(..))
8 import Control.Monad (Monad(..))
9 import Data.Char (Char)
10 import Data.Either (Either(..))
11 import Data.Function (($), (.))
12 import Data.Functor (Functor(..), (<$>))
13 import Data.Ord (Ord(..))
14 import Data.String (String, IsString(..))
15 import Data.Typeable ()
16 import Text.Show (Show(..))
17 import qualified Control.Applicative as Alt
18 import qualified Control.Monad.Classes as MC
19 import qualified Data.Char as Char
20 import qualified Data.List as List
21 import qualified Data.Text as Text
22 import qualified Data.Text.Lazy as TL
23 import qualified Text.Megaparsec as P
24 import qualified Text.Megaparsec.Char as P
25
26 import Language.Symantic.Grammar as Sym
27 import qualified Language.Symantic as Sym
28 import Language.Symantic.Lib ()
29
30 -- * Type 'ParsecC'
31 -- | Convenient alias for defining instances involving 'P.ParsecT'.
32 type ParsecC e s = (P.Token s ~ Char, P.Stream s, Ord e)
33 instance ParsecC e [Char] => IsString (P.ParsecT e [Char] m [Char]) where
34 fromString = P.string
35
36 --
37 -- Readers
38 --
39
40 {-
41 -- P.SourcePos
42 instance ParsecC e s => Sym.Gram_Reader P.SourcePos (P.ParsecT e s m) where
43 askBefore g = do
44 s <- P.getSourcePos
45 ($ s) <$> g
46 askAfter g = do
47 f <- g
48 f <$> P.getSourcePos
49 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader P.SourcePos) = 'True
50 instance ParsecC e s => MC.MonadReaderN 'MC.Zero P.SourcePos (P.ParsecT e s m) where
51 askN _n = P.getSourcePos
52 -}
53 -- ()
54 instance ParsecC e s => Sym.Gram_Reader () (P.ParsecT e s m) where
55 askBefore = fmap ($ ())
56 askAfter = fmap ($ ())
57
58 --
59 -- States
60 --
61
62 -- st
63 type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
64 instance (Monad m, MC.MonadState st m) => Sym.Gram_State st m where
65 stateBefore g = do
66 s <- MC.get
67 f <- g
68 let (s', a) = f s
69 MC.put s'
70 return a
71 stateAfter g = do
72 f <- g
73 s <- MC.get
74 let (s_, a) = f s
75 MC.put s_
76 return a
77 getBefore g = do
78 s <- MC.get
79 f <- g
80 return (f s)
81 getAfter g = do
82 f <- g
83 s <- MC.get
84 return (f s)
85 put g = do
86 (s, a) <- g
87 MC.put s
88 return a
89
90 --
91 -- Sym instances
92 --
93 instance (ParsecC e s, Show err) => Sym.Gram_Error err (P.ParsecT e s m) where
94 catch me {- if you can :-} = do
95 e <- me
96 case e of
97 Left err -> fail $ show err
98 Right a -> return a
99 instance ParsecC e s => Sym.Gram_Rule (P.ParsecT e s m) where
100 rule = P.label . Text.unpack
101 instance ParsecC e s => Sym.Gram_Char (P.ParsecT e s m) where
102 any = P.anySingle
103 eoi = P.eof
104 char = P.char
105 unicat cat = P.satisfy $ (`List.elem` cats) . Char.generalCategory
106 where cats = unicode_categories cat
107 range (l, h) = P.satisfy $ \c -> l <= c && c <= h
108 Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
109 instance ParsecC e String => Sym.Gram_String (P.ParsecT e String m) where
110 string = P.string
111 instance ParsecC e Text.Text => Sym.Gram_String (P.ParsecT e Text.Text m) where
112 string t = Text.unpack <$> P.string (Text.pack t)
113 text = P.string
114 textLazy t = TL.fromStrict <$> P.string (TL.toStrict t)
115 instance ParsecC e s => Sym.Gram_Alt (P.ParsecT e s m) where
116 empty = Alt.empty
117 (<+>) = (Alt.<|>)
118 choice = P.choice
119 instance ParsecC e s => Sym.Gram_Try (P.ParsecT e s m) where
120 try = P.try
121 instance ParsecC e s => Sym.Gram_RegR (P.ParsecT e s m) where
122 Terminal f .*> Reg x = Reg $ f <*> x
123 instance ParsecC e s => Sym.Gram_RegL (P.ParsecT e s m) where
124 Reg f <*. Terminal x = Reg $ f <*> x
125 instance ParsecC e s => Sym.Gram_App (P.ParsecT e s m) where
126 between = P.between
127 instance ParsecC e s => Sym.Gram_AltApp (P.ParsecT e s m) where
128 option = P.option
129 optional = P.optional
130 many = P.many
131 some = P.some
132 manySkip = P.skipMany
133 instance ParsecC e s => Sym.Gram_CF (P.ParsecT e s m) where
134 CF f <& Reg p = CF $ P.lookAhead f <*> p
135 Reg f &> CF p = CF $ P.lookAhead f <*> p
136 minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
137 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Comment (P.ParsecT e s m)
138 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Op (P.ParsecT e s m)
139 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Mod (P.ParsecT e s m)
140 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Type_Name (P.ParsecT e s m)
141 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Term_Name (P.ParsecT e s m)
142 instance -- Sym.Gram_Type
143 ( ParsecC e s
144 , Sym.Gram_String (P.ParsecT e s m)
145 , Gram_Source src (P.ParsecT e s m)
146 , Show src
147 , MC.MonadState ( Sym.Imports Sym.NameTy
148 , Sym.ModulesTy src )
149 (P.ParsecT e s m)
150 ) => Sym.Gram_Type src (P.ParsecT e s m)
151 instance -- Sym.Gram_Term_Type
152 ( ParsecC e s
153 , Sym.Gram_String (P.ParsecT e s m)
154 , Show src
155 , MC.MonadState ( Sym.Imports Sym.NameTy
156 , Sym.ModulesTy src )
157 (P.ParsecT e s m)
158 , Gram_Source src (P.ParsecT e s m)
159 ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
160 instance -- Sym.Gram_Term
161 ( ParsecC e s
162 , Sym.Gram_String (P.ParsecT e s m)
163 , Show src
164 , MC.MonadState ( Sym.Imports Sym.NameTy
165 , Sym.ModulesTy src )
166 (P.ParsecT e s m)
167 , MC.MonadState ( Sym.Imports Sym.NameTe
168 , Sym.Modules src ss )
169 (P.ParsecT e s m)
170 , Sym.Gram_Source src (P.ParsecT e s m)
171 , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
172 ) => Sym.Gram_Term src ss (P.ParsecT e s m)