From b16e56a555b37c5d0c01074b6c6a0dbcbb100bfe Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 31 Jul 2016 18:47:51 +0200 Subject: framework for parsing Specs --- events/events.cabal | 8 ++++++++ events/events.nix | 12 +++++++----- events/src/Events/Spec.hs | 11 +++-------- events/src/Events/Spec/Parse.hs | 24 ++++++++++++++++++++++++ events/src/Events/Spec/Types.hs | 13 +++++++++++++ 5 files changed, 55 insertions(+), 13 deletions(-) create mode 100644 events/src/Events/Spec/Parse.hs diff --git a/events/events.cabal b/events/events.cabal index 93a2daf..4ab12fd 100644 --- a/events/events.cabal +++ b/events/events.cabal @@ -21,6 +21,9 @@ executable events other-modules: Events.Types , Events.Types.NDT , Events.Eval + , Events.Spec + , Events.Spec.Types + , Events.Spec.Eval -- other-extensions: build-depends: base >=4.8 && <5 , lens >=4.13 && <5 @@ -36,5 +39,10 @@ executable events , transformers >=0.4.2 && <1 , list-t >=0.4.6 && <1 , data-default-class >=0.0.1 && <1 + , text >=1.2.2.1 && <2 + , conduit >=1.2.6.6 && <2 + , conduit-extra >=1.1.13.2 && <2 + , attoparsec >=0.13.0.2 && <1 + , exceptions >=0.8.3 && <1 hs-source-dirs: src default-language: Haskell2010 \ No newline at end of file diff --git a/events/events.nix b/events/events.nix index 26f598b..3f5d798 100644 --- a/events/events.nix +++ b/events/events.nix @@ -1,6 +1,7 @@ -{ mkDerivation, aeson, aeson-lens, base, bytestring -, data-default-class, lens, lens-time, list-t, mmorph, mtl, stdenv -, time, transformers, tz, yaml +{ mkDerivation, aeson, aeson-lens, attoparsec, base, bytestring +, conduit, conduit-extra, data-default-class, exceptions, lens +, lens-time, list-t, mmorph, mtl, stdenv, text, time, transformers +, tz, yaml }: mkDerivation { pname = "events"; @@ -9,8 +10,9 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - aeson aeson-lens base bytestring data-default-class lens lens-time - list-t mmorph mtl time transformers tz yaml + aeson aeson-lens attoparsec base bytestring conduit conduit-extra + data-default-class exceptions lens lens-time list-t mmorph mtl text + time transformers tz yaml ]; homepage = "https://git.yggdrasil.li/gkleen/pub/events"; description = "An appointment book"; diff --git a/events/src/Events/Spec.hs b/events/src/Events/Spec.hs index e098886..cfa75be 100644 --- a/events/src/Events/Spec.hs +++ b/events/src/Events/Spec.hs @@ -3,12 +3,14 @@ module Events.Spec ( interpret , Spec, Cmnd(..), Expr(..), Elem(..) + , module Events.Spec.Parse ) where -import Events.Types import Events.Spec.Types import Events.Spec.Eval +import Events.Spec.Parse + import Control.Monad ((<=<)) import Control.Monad.IO.Class import Control.Monad.State.Lazy @@ -19,13 +21,6 @@ import Control.Lens import Debug.Trace -type Spec m = Expr (Eval m) '[] Cmnd -- most significant last - -data Cmnd = COverride Object - | COccurs Bool - | CNop - deriving (Show) - interpret :: MonadIO m => Spec m -> Eval m () interpret = join . fmap interpretCmnd . evalExpr diff --git a/events/src/Events/Spec/Parse.hs b/events/src/Events/Spec/Parse.hs new file mode 100644 index 0000000..912a308 --- /dev/null +++ b/events/src/Events/Spec/Parse.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GADTs, DataKinds, OverloadedStrings #-} + +module Events.Spec.Parse + ( parse + , Position(..), ParseError(..) + ) where + +import Data.Conduit.Attoparsec +import Data.Conduit + +import Data.Attoparsec.Text hiding (parse) + +import Data.Text (Text) +import qualified Data.Text as T + +import Events.Spec.Types + +import Control.Monad.Catch (MonadThrow) + +parse :: MonadThrow m => Consumer Text m (Spec m) +parse = sinkParser $ (tokenize >>= pSpec) <* endOfInput + +pSpec :: Monad m => Parser (Spec m) +pSpec = mzero diff --git a/events/src/Events/Spec/Types.hs b/events/src/Events/Spec/Types.hs index 665958d..5216f46 100644 --- a/events/src/Events/Spec/Types.hs +++ b/events/src/Events/Spec/Types.hs @@ -3,11 +3,16 @@ module Events.Spec.Types ( Expr(..) , Val(..) + , Spec + , Cmnd(..) , Elem(..) , Length(..) , type (++)(..) + , module Events.Types ) where +import Events.Types + data Expr :: (* -> *) -> [*] -> * -> * where ELit :: Val m a -> Expr m ctx a EVar :: Elem a ctx -> Expr m ctx a @@ -18,6 +23,13 @@ type family Val m a where Val m (a -> b) = Expr m '[a] b Val m a = m a +type Spec m = Expr (Eval m) '[] Cmnd + +data Cmnd = COverride Object + | COccurs Bool + | CNop + deriving (Show) + data Elem :: a -> [a] -> * where EZ :: Elem x (x ': xs) ES :: Elem x xs -> Elem x (y ': xs) @@ -30,3 +42,4 @@ type family (xs :: [a]) ++ (ys :: [a]) :: [a] type instance '[] ++ ys = ys type instance (x ': xs) ++ ys = x ': (xs ++ ys) infixr 5 ++ + -- cgit v1.2.3