]> Git — Sourcephile - haskell/symantic.git/blob - symantic-lib/test/Testing/Megaparsec.hs
Reorganize symantic-document modules.
[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.List.NonEmpty (NonEmpty(..))
14 import Data.Ord (Ord(..))
15 import Data.String (IsString(..))
16 import Data.Typeable ()
17 import Text.Show (Show(..))
18 import qualified Control.Applicative as Alt
19 import qualified Control.Monad.Classes as MC
20 import qualified Data.Char as Char
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 -- NonEmpty P.SourcePos
41 instance ParsecC e s => Sym.Gram_Reader (NonEmpty P.SourcePos) (P.ParsecT e s m) where
42 askBefore g = do
43 s <- P.statePos <$> P.getParserState
44 ($ s) <$> g
45 askAfter g = do
46 f <- g
47 f . P.statePos <$> P.getParserState
48 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (NonEmpty P.SourcePos)) = 'True
49 instance ParsecC e s => MC.MonadReaderN 'MC.Zero (NonEmpty P.SourcePos) (P.ParsecT e s m) where
50 askN _n = P.statePos <$> P.getParserState
51 -- P.SourcePos
52 instance ParsecC e s => Sym.Gram_Reader P.SourcePos (P.ParsecT e s m) where
53 askBefore g = do
54 s <- P.getPosition
55 ($ s) <$> g
56 askAfter g = do
57 f <- g
58 f <$> P.getPosition
59 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader P.SourcePos) = 'True
60 instance ParsecC e s => MC.MonadReaderN 'MC.Zero P.SourcePos (P.ParsecT e s m) where
61 askN _n = P.getPosition
62 -- ()
63 instance ParsecC e s => Sym.Gram_Reader () (P.ParsecT e s m) where
64 askBefore = fmap ($ ())
65 askAfter = fmap ($ ())
66
67 --
68 -- States
69 --
70
71 -- st
72 type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
73 instance (Monad m, MC.MonadState st m) => Sym.Gram_State st m where
74 stateBefore g = do
75 s <- MC.get
76 f <- g
77 let (s', a) = f s
78 MC.put s'
79 return a
80 stateAfter g = do
81 f <- g
82 s <- MC.get
83 let (s_, a) = f s
84 MC.put s_
85 return a
86 getBefore g = do
87 s <- MC.get
88 f <- g
89 return (f s)
90 getAfter g = do
91 f <- g
92 s <- MC.get
93 return (f s)
94 put g = do
95 (s, a) <- g
96 MC.put s
97 return a
98
99 --
100 -- Sym instances
101 --
102 instance (ParsecC e s, Show err) => Sym.Gram_Error err (P.ParsecT e s m) where
103 catch me {- if you can :-} = do
104 e <- me
105 case e of
106 Left err -> fail $ show err
107 Right a -> return a
108 instance ParsecC e s => Sym.Gram_Rule (P.ParsecT e s m) where
109 rule = P.label . Text.unpack
110 instance ParsecC e s => Sym.Gram_Char (P.ParsecT e s m) where
111 any = P.anyChar
112 eoi = P.eof
113 char = P.char
114 unicat cat = P.satisfy $ (`elem` cats) . Char.generalCategory
115 where cats = unicode_categories cat
116 range (l, h) = P.satisfy $ \c -> l <= c && c <= h
117 Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
118 instance ParsecC e String => Sym.Gram_String (P.ParsecT e String m) where
119 string = P.string
120 instance ParsecC e Text.Text => Sym.Gram_String (P.ParsecT e Text.Text m) where
121 string t = Text.unpack <$> P.string (Text.pack t)
122 text = P.string
123 textLazy t = TL.fromStrict <$> P.string (TL.toStrict t)
124 instance ParsecC e s => Sym.Gram_Alt (P.ParsecT e s m) where
125 empty = Alt.empty
126 (<+>) = (Alt.<|>)
127 choice = P.choice
128 instance ParsecC e s => Sym.Gram_Try (P.ParsecT e s m) where
129 try = P.try
130 instance ParsecC e s => Sym.Gram_RegR (P.ParsecT e s m) where
131 Terminal f .*> Reg x = Reg $ f <*> x
132 instance ParsecC e s => Sym.Gram_RegL (P.ParsecT e s m) where
133 Reg f <*. Terminal x = Reg $ f <*> x
134 instance ParsecC e s => Sym.Gram_App (P.ParsecT e s m) where
135 between = P.between
136 instance ParsecC e s => Sym.Gram_AltApp (P.ParsecT e s m) where
137 option = P.option
138 optional = P.optional
139 many = P.many
140 some = P.some
141 manySkip = P.skipMany
142 instance ParsecC e s => Sym.Gram_CF (P.ParsecT e s m) where
143 CF f <& Reg p = CF $ P.lookAhead f <*> p
144 Reg f &> CF p = CF $ P.lookAhead f <*> p
145 minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
146 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Comment (P.ParsecT e s m)
147 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Op (P.ParsecT e s m)
148 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Mod (P.ParsecT e s m)
149 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Type_Name (P.ParsecT e s m)
150 instance (ParsecC e s, Sym.Gram_String (P.ParsecT e s m)) => Sym.Gram_Term_Name (P.ParsecT e s m)
151 instance -- Sym.Gram_Type
152 ( ParsecC e s
153 , Sym.Gram_String (P.ParsecT e s m)
154 , Gram_Source src (P.ParsecT e s m)
155 , Show src
156 , MC.MonadState ( Sym.Imports Sym.NameTy
157 , Sym.ModulesTy src )
158 (P.ParsecT e s m)
159 ) => Sym.Gram_Type src (P.ParsecT e s m)
160 instance -- Sym.Gram_Term_Type
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 , Gram_Source src (P.ParsecT e s m)
168 ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
169 instance -- Sym.Gram_Term
170 ( ParsecC e s
171 , Sym.Gram_String (P.ParsecT e s m)
172 , Show src
173 , MC.MonadState ( Sym.Imports Sym.NameTy
174 , Sym.ModulesTy src )
175 (P.ParsecT e s m)
176 , MC.MonadState ( Sym.Imports Sym.NameTe
177 , Sym.Modules src ss )
178 (P.ParsecT e s m)
179 , Sym.Gram_Source src (P.ParsecT e s m)
180 , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
181 ) => Sym.Gram_Term src ss (P.ParsecT e s m)