From 05726e8f6c34c10ca7cee54bb583fbbe2c877569 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <pngwjpgh@users.noreply.github.com>
Date: Wed, 10 Aug 2016 17:24:17 +0200
Subject: Switch to megaparsec & parsing framework

---
 events/src/Events/Spec/Parse.hs       | 26 +++++++++++++--------
 events/src/Events/Spec/Parse/AST.hs   | 19 ++++++++++++++++
 events/src/Events/Spec/Parse/Token.hs | 43 +++++++++++++++++++++++++++++++++++
 3 files changed, 78 insertions(+), 10 deletions(-)
 create mode 100644 events/src/Events/Spec/Parse/AST.hs
 create mode 100644 events/src/Events/Spec/Parse/Token.hs

(limited to 'events/src/Events')

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 @@
 {-# LANGUAGE GADTs, DataKinds, OverloadedStrings #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE StandaloneDeriving, FlexibleContexts #-}
 
 module Events.Spec.Parse
   ( parse
   , ParseError(..)
+  , TypeError(..)
   ) where
 
 import Events.Spec.Types
+import Events.Spec.Parse.Token
+import Events.Spec.Parse.AST
 
-import Text.Parsec hiding (parse, ParseError)
-import qualified Text.Parsec as Parsec (parse, ParseError)
+import Text.Megaparsec hiding (parse)
+import qualified Text.Megaparsec.Lexer as L
 
 import Data.Text (Text)
 import qualified Data.Text as Text
@@ -23,13 +26,16 @@ import Data.Typeable (Typeable)
 import Control.Monad.Catch (Exception(..), MonadThrow(..))
 
 
-newtype ParseError = ParseError Parsec.ParseError
-  deriving (Typeable, Show, Eq)
-instance Exception ParseError
+data TypeError = TypeError
+  deriving (Typeable, Show)
 
+instance Exception TypeError
 
-parse :: MonadThrow m => SourceName -> Lazy.Text -> Eval m (Spec m)
-parse name = either (throwM . ParseError) return <=< runParserT pSpec () name
 
-pSpec :: ParsecT Lazy.Text () (Eval m) (Spec m)
-pSpec = mzero
+parse :: (MonadIO m, MonadThrow m) => String -> Lazy.Text -> m (Spec m)
+parse name = typecheck <=< runParserT' pAST name <=< runParserT' pTokens name
+  where
+    runParserT' parser name = either throwM return <=< runParserT parser name
+
+typecheck :: MonadThrow m => AST -> m (Spec m)
+typecheck = 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 @@
+{-# LANGUAGE GADTs, DataKinds, OverloadedStrings #-}
+
+module Events.Spec.Parse.AST
+  ( AST(..)
+  , pAST
+  ) where
+
+import Events.Spec.Types
+import Events.Spec.Parse.Token
+
+import Text.Megaparsec hiding (parse)
+  
+import Data.Typeable (Typeable)
+
+data AST = AST
+  deriving (Typeable)
+
+pAST :: ParsecT Dec [SpecToken] m AST
+pAST = 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 @@
+{-# LANGUAGE GADTs, DataKinds, OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances, TypeFamilies #-}
+
+module Events.Spec.Parse.Token
+  ( SpecToken(..)
+  , pToken, pTokens
+  ) where
+
+import Events.Spec.Types
+
+import Text.Megaparsec hiding (parse)
+import Text.Megaparsec.Pos
+import qualified Text.Megaparsec.Lexer as L
+
+import Data.Typeable (Typeable)
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+import Data.Text.Lazy as Lazy (Text)
+import qualified Data.Text.Lazy as Lazy.Text
+
+data SpecToken = Token
+  deriving (Typeable, Show, Eq, Ord)
+
+instance Stream [SpecToken] where
+  type Token [SpecToken] = SpecToken
+
+  uncons [] = Nothing
+  uncons (s:ss) = Just (s, ss)
+
+  updatePos = undefined
+
+
+tSpace :: ParsecT Dec Lazy.Text m ()
+tSpace = L.space (() <$ spaceChar) (L.skipLineComment "--") (L.skipBlockComment "{-" "-}")
+
+pToken :: ParsecT Dec Lazy.Text m SpecToken
+pToken = mzero {- TODO -}
+
+pTokens :: ParsecT Dec Lazy.Text m [SpecToken]
+pTokens = manyTill (tSpace *> pToken <* tSpace) eof
-- 
cgit v1.2.3