Switch to megaparsec & parsing framework

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
                      , Events.Spec
                      , Events.Spec.Types
                      , Events.Spec.Eval
+                     , Events.Spec.Parse
+                     , Events.Spec.Parse.Token
+                     , Events.Spec.Parse.AST
   -- other-extensions:    
   build-depends:       base >=4.8 && <5
                      , lens >=4.13 && <5
@@ -40,7 +43,7 @@ executable events
                      , list-t >=0.4.6 && <1
                      , data-default-class >=0.0.1 && <1
                      , text >=1.2.2.1 && <2
-                     , parsec >=3.1.11 && <4
+                     , megaparsec >=5.0.1 && <6
                      , exceptions >=0.8.3 && <1
   hs-source-dirs:      src
   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 @@
 { mkDerivation, aeson, aeson-lens, base, bytestring
 , data-default-class, exceptions, lens, lens-time, list-t, mmorph
-, mtl, parsec, stdenv, text, time, transformers, tz, yaml
+, mtl, megaparsec, stdenv, text, time, transformers, tz, yaml
 }:
 mkDerivation {
   pname = "events";
@@ -10,7 +10,7 @@ mkDerivation {
   isExecutable = true;
   executableHaskellDepends = [
     aeson aeson-lens base bytestring data-default-class exceptions lens
-    lens-time list-t mmorph mtl parsec text time transformers tz yaml
+    lens-time list-t mmorph mtl megaparsec text time transformers tz yaml
   ];
   homepage = "https://git.yggdrasil.li/gkleen/pub/events";
   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 @@
 {-# 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