summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--events/events.cabal5
-rw-r--r--events/events.nix4
-rw-r--r--events/src/Events/Spec/Parse.hs26
-rw-r--r--events/src/Events/Spec/Parse/AST.hs19
-rw-r--r--events/src/Events/Spec/Parse/Token.hs43
5 files changed, 84 insertions, 13 deletions
diff --git a/events/events.cabal b/events/events.cabal
index 33909ff..f8d23dd 100644
--- a/events/events.cabal
+++ b/events/events.cabal
@@ -24,6 +24,9 @@ executable events
24 , Events.Spec 24 , Events.Spec
25 , Events.Spec.Types 25 , Events.Spec.Types
26 , Events.Spec.Eval 26 , Events.Spec.Eval
27 , Events.Spec.Parse
28 , Events.Spec.Parse.Token
29 , Events.Spec.Parse.AST
27 -- other-extensions: 30 -- other-extensions:
28 build-depends: base >=4.8 && <5 31 build-depends: base >=4.8 && <5
29 , lens >=4.13 && <5 32 , lens >=4.13 && <5
@@ -40,7 +43,7 @@ executable events
40 , list-t >=0.4.6 && <1 43 , list-t >=0.4.6 && <1
41 , data-default-class >=0.0.1 && <1 44 , data-default-class >=0.0.1 && <1
42 , text >=1.2.2.1 && <2 45 , text >=1.2.2.1 && <2
43 , parsec >=3.1.11 && <4 46 , megaparsec >=5.0.1 && <6
44 , exceptions >=0.8.3 && <1 47 , exceptions >=0.8.3 && <1
45 hs-source-dirs: src 48 hs-source-dirs: src
46 default-language: Haskell2010 49 default-language: Haskell2010
diff --git a/events/events.nix b/events/events.nix
index 72d5518..f124baa 100644
--- a/events/events.nix
+++ b/events/events.nix
@@ -1,6 +1,6 @@
1{ mkDerivation, aeson, aeson-lens, base, bytestring 1{ mkDerivation, aeson, aeson-lens, base, bytestring
2, data-default-class, exceptions, lens, lens-time, list-t, mmorph 2, data-default-class, exceptions, lens, lens-time, list-t, mmorph
3, mtl, parsec, stdenv, text, time, transformers, tz, yaml 3, mtl, megaparsec, stdenv, text, time, transformers, tz, yaml
4}: 4}:
5mkDerivation { 5mkDerivation {
6 pname = "events"; 6 pname = "events";
@@ -10,7 +10,7 @@ mkDerivation {
10 isExecutable = true; 10 isExecutable = true;
11 executableHaskellDepends = [ 11 executableHaskellDepends = [
12 aeson aeson-lens base bytestring data-default-class exceptions lens 12 aeson aeson-lens base bytestring data-default-class exceptions lens
13 lens-time list-t mmorph mtl parsec text time transformers tz yaml 13 lens-time list-t mmorph mtl megaparsec text time transformers tz yaml
14 ]; 14 ];
15 homepage = "https://git.yggdrasil.li/gkleen/pub/events"; 15 homepage = "https://git.yggdrasil.li/gkleen/pub/events";
16 description = "An appointment book"; 16 description = "An appointment book";
diff --git a/events/src/Events/Spec/Parse.hs b/events/src/Events/Spec/Parse.hs
index 44aabd0..2847372 100644
--- a/events/src/Events/Spec/Parse.hs
+++ b/events/src/Events/Spec/Parse.hs
@@ -1,15 +1,18 @@
1{-# LANGUAGE GADTs, DataKinds, OverloadedStrings #-} 1{-# LANGUAGE GADTs, DataKinds, OverloadedStrings #-}
2{-# LANGUAGE StandaloneDeriving #-} 2{-# LANGUAGE StandaloneDeriving, FlexibleContexts #-}
3 3
4module Events.Spec.Parse 4module Events.Spec.Parse
5 ( parse 5 ( parse
6 , ParseError(..) 6 , ParseError(..)
7 , TypeError(..)
7 ) where 8 ) where
8 9
9import Events.Spec.Types 10import Events.Spec.Types
11import Events.Spec.Parse.Token
12import Events.Spec.Parse.AST
10 13
11import Text.Parsec hiding (parse, ParseError) 14import Text.Megaparsec hiding (parse)
12import qualified Text.Parsec as Parsec (parse, ParseError) 15import qualified Text.Megaparsec.Lexer as L
13 16
14import Data.Text (Text) 17import Data.Text (Text)
15import qualified Data.Text as Text 18import qualified Data.Text as Text
@@ -23,13 +26,16 @@ import Data.Typeable (Typeable)
23import Control.Monad.Catch (Exception(..), MonadThrow(..)) 26import Control.Monad.Catch (Exception(..), MonadThrow(..))
24 27
25 28
26newtype ParseError = ParseError Parsec.ParseError 29data TypeError = TypeError
27 deriving (Typeable, Show, Eq) 30 deriving (Typeable, Show)
28instance Exception ParseError
29 31
32instance Exception TypeError
30 33
31parse :: MonadThrow m => SourceName -> Lazy.Text -> Eval m (Spec m)
32parse name = either (throwM . ParseError) return <=< runParserT pSpec () name
33 34
34pSpec :: ParsecT Lazy.Text () (Eval m) (Spec m) 35parse :: (MonadIO m, MonadThrow m) => String -> Lazy.Text -> m (Spec m)
35pSpec = mzero 36parse name = typecheck <=< runParserT' pAST name <=< runParserT' pTokens name
37 where
38 runParserT' parser name = either throwM return <=< runParserT parser name
39
40typecheck :: MonadThrow m => AST -> m (Spec m)
41typecheck = undefined
diff --git a/events/src/Events/Spec/Parse/AST.hs b/events/src/Events/Spec/Parse/AST.hs
new file mode 100644
index 0000000..38c2c84
--- /dev/null
+++ b/events/src/Events/Spec/Parse/AST.hs
@@ -0,0 +1,19 @@
1{-# LANGUAGE GADTs, DataKinds, OverloadedStrings #-}
2
3module Events.Spec.Parse.AST
4 ( AST(..)
5 , pAST
6 ) where
7
8import Events.Spec.Types
9import Events.Spec.Parse.Token
10
11import Text.Megaparsec hiding (parse)
12
13import Data.Typeable (Typeable)
14
15data AST = AST
16 deriving (Typeable)
17
18pAST :: ParsecT Dec [SpecToken] m AST
19pAST = mzero {- TODO -}
diff --git a/events/src/Events/Spec/Parse/Token.hs b/events/src/Events/Spec/Parse/Token.hs
new file mode 100644
index 0000000..df6f09e
--- /dev/null
+++ b/events/src/Events/Spec/Parse/Token.hs
@@ -0,0 +1,43 @@
1{-# LANGUAGE GADTs, DataKinds, OverloadedStrings #-}
2{-# LANGUAGE StandaloneDeriving #-}
3{-# LANGUAGE FlexibleInstances, TypeFamilies #-}
4
5module Events.Spec.Parse.Token
6 ( SpecToken(..)
7 , pToken, pTokens
8 ) where
9
10import Events.Spec.Types
11
12import Text.Megaparsec hiding (parse)
13import Text.Megaparsec.Pos
14import qualified Text.Megaparsec.Lexer as L
15
16import Data.Typeable (Typeable)
17
18import Data.Text (Text)
19import qualified Data.Text as Text
20
21import Data.Text.Lazy as Lazy (Text)
22import qualified Data.Text.Lazy as Lazy.Text
23
24data SpecToken = Token
25 deriving (Typeable, Show, Eq, Ord)
26
27instance Stream [SpecToken] where
28 type Token [SpecToken] = SpecToken
29
30 uncons [] = Nothing
31 uncons (s:ss) = Just (s, ss)
32
33 updatePos = undefined
34
35
36tSpace :: ParsecT Dec Lazy.Text m ()
37tSpace = L.space (() <$ spaceChar) (L.skipLineComment "--") (L.skipBlockComment "{-" "-}")
38
39pToken :: ParsecT Dec Lazy.Text m SpecToken
40pToken = mzero {- TODO -}
41
42pTokens :: ParsecT Dec Lazy.Text m [SpecToken]
43pTokens = manyTill (tSpace *> pToken <* tSpace) eof