From 96db1757879ca89168e5e717e4ca417fc4322282 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Sat, 15 Sep 2012 14:01:13 -0400 Subject: [PATCH] Initial REPL --- dyna.cabal | 41 ++++++++++++++++++++++----- src/Dyna/NormalizeParse.hs | 6 ++-- src/Dyna/ParserHS/Parser.hs | 3 +- src/Dyna/REPL.hs | 41 +++++++++++++++++++++++++++ src/Dyna/Test/Trifecta.hs | 4 ++- src/Dyna/XXX/Trifecta.hs | 55 ++++++++++++++++++++++++++++++++++++- 6 files changed, 137 insertions(+), 13 deletions(-) create mode 100644 src/Dyna/REPL.hs diff --git a/dyna.cabal b/dyna.cabal index 077492c..5f824ed 100644 --- a/dyna.cabal +++ b/dyna.cabal @@ -1,8 +1,8 @@ ---------------------------------------------------------------- Name: dyna -Version: 0.3.5 -Cabal-Version: >= 1.14 +Version: 0.4 +Cabal-Version: >=1.14 Build-Type: Simple Stability: alpha Copyright: Copyright (c) 2007--2012, @@ -23,34 +23,61 @@ Library Default-Language: Haskell2010 Hs-Source-Dirs: src - Exposed-Modules: Dyna.ParserHS.Parser + ghc-options: -Wall + + Exposed-Modules: Dyna.ParserHS.Parser, + Dyna.NormalizeParse, + Dyna.XXX.Trifecta Build-Depends: base >=4, - bytestring >= 0.9, + bytestring >=0.9, + containers >=0.4, + mtl >=2.1, + reducers >=3.0, semigroups >=0.8, trifecta >=0.53, unification-fd, unordered-containers>=0.2, utf8-string >=0.3 +Executable drepl + Default-Language: Haskell2010 + + ghc-options: -Wall + + Hs-Source-Dirs: src + Build-Depends: base >=4, + bytestring >=0.9, + containers >=0.4, + editline >=0.2, + reducers >=3.0, + semigroups >=0.8, + trifecta >=0.53, + unordered-containers>=0.2, + utf8-string >=0.3 + + Main-Is: Dyna/REPL.hs + Test-suite dyna-selftest-parser type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: src - Build-Depends: base >= 4, + Build-Depends: base >=4, bytestring >=0.9, containers >=0.4, HUnit >=1.2, + reducers >=3.0, semigroups >=0.8, test-framework >=0.6, - test-framework-hunit >= 0.2, - test-framework-th >= 0.2, + test-framework-hunit >=0.2, + test-framework-th >=0.2, trifecta >=0.53, unordered-containers>=0.2, utf8-string >=0.3 Main-Is: Dyna/ParserHS/ParserSelftest.hs + ---------------------------------------------------------------- ----------------------------------------------------------- fin. diff --git a/src/Dyna/NormalizeParse.hs b/src/Dyna/NormalizeParse.hs index 7cb3377..c78b589 100644 --- a/src/Dyna/NormalizeParse.hs +++ b/src/Dyna/NormalizeParse.hs @@ -14,7 +14,7 @@ import qualified Data.Set as S import qualified Text.Trifecta as T import qualified Dyna.ParserHS.Parser as P -import Dyna.Test.Trifecta -- XXX +-- import Dyna.Test.Trifecta -- XXX data Term = TFunctor !B.ByteString ![Term] | TVar !B.ByteString @@ -129,7 +129,7 @@ run = flip runStateT (AS 0 S.empty) . flip runReaderT (AD dynaFunctorArgDispositions dynaFunctorSelfDispositions) -- XXX -testNormTerm = run . normalizeTerm False . unsafeParse P.dterm +-- testNormTerm = run . normalizeTerm False . unsafeParse P.dterm normalizeRule (P.Fact t T.:~ _) = do nt <- normalizeTerm False t @@ -140,7 +140,7 @@ normalizeRule (P.Rule h a es r T.:~ _) = do nes <- mapM (normalizeTerm True) es return $ Rule nh a nes nr -testNormRule = run . normalizeRule . unsafeParse P.drule +-- testNormRule = run . normalizeRule . unsafeParse P.drule {- neis e = newEval "_normE_" $ \v -> EIs v e diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index 3802dbc..13fe26e 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -186,7 +186,8 @@ progline = spanned $ choice [ LRule <$> drule ] dline :: MonadParser m => m (Spanned Line) -dline = dynafy (progline <* optional (char '.' <* (spaces <|> eof))) +-- dline = dynafy (progline <* optional (char '.' <* (spaces <|> eof))) +dline = dynafy (progline <* optional (char '.') <* optional newline) dlines :: MonadParser m => m [Spanned Line] dlines = dynafy (progline `sepEndBy` (char '.' <* spaces)) diff --git a/src/Dyna/REPL.hs b/src/Dyna/REPL.hs new file mode 100644 index 0000000..8a3947f --- /dev/null +++ b/src/Dyna/REPL.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE Rank2Types #-} +module Main where + +import Control.Applicative ((<*)) +import qualified Data.Foldable as F +import System.Console.Editline +import Text.Trifecta + +import qualified Dyna.ParserHS.Parser as DP +-- import qualified Dyna.NormalizeParse as DNP +import Dyna.XXX.Trifecta + +main :: IO () +main = do + el <- elInit "dyna" + setEditor el Emacs + let + loop = do + setPrompt el (return "Dyna> ") + maybeLine <- elGets el + case maybeLine of + Nothing -> return () -- ctrl-D + Just l -> triInteract (DP.dline <* eof) + promptCont + success + failure + l + + + promptCont = do + setPrompt el (return " > ") + elGets el + + success a = do + putStrLn $ "\nParsed: " ++ show a + loop + + failure sd = do + displayLn $ F.toList sd + loop + loop diff --git a/src/Dyna/Test/Trifecta.hs b/src/Dyna/Test/Trifecta.hs index e0d8907..431df44 100644 --- a/src/Dyna/Test/Trifecta.hs +++ b/src/Dyna/Test/Trifecta.hs @@ -2,7 +2,7 @@ module Dyna.Test.Trifecta where -import Control.Applicative ((<*)) +import Control.Applicative ((<*),(*>)) import Data.ByteString (ByteString) import Data.Foldable (toList) import Data.Monoid (mempty) @@ -32,3 +32,5 @@ checkParseFail p i e = unsafeFF e $ parseByteString (p <* eof) mempty i extractDiag (Diagnostic (Left s) _ m _) = (Left s, show m) extractDiag (Diagnostic (Right (Rendering d _ _ _ _)) _ m _) = (Right d, show m) + + diff --git a/src/Dyna/XXX/Trifecta.hs b/src/Dyna/XXX/Trifecta.hs index 53596b0..74696f8 100644 --- a/src/Dyna/XXX/Trifecta.hs +++ b/src/Dyna/XXX/Trifecta.hs @@ -1,15 +1,43 @@ +{-# LANGUAGE RankNTypes #-} -- XXX contribute back to trifecta module Dyna.XXX.Trifecta ( - identNL, pureSpanned + identNL, pureSpanned, stepParserBS, triInteract ) where import Data.ByteString as Strict hiding (map, zip, foldl, foldr) +import qualified Data.ByteString.UTF8 as BU import Control.Applicative import Control.Monad (when) import Data.HashSet as HashSet (member) +import Data.Monoid +import qualified Data.Semigroup.Reducer as R +import qualified Data.Sequence as Q import Text.Trifecta +import qualified Text.Trifecta.Parser.Step as TPS +import qualified Text.Trifecta.Parser.Mark as TPM + + -- XXX +import Debug.Trace + +-- | Step a trifecta parser +-- +-- based on Text.Trifecta.Parser.parseByteString +stepParserBS :: Show a + => (forall r. Parser r String a) + -> Delta + -> ByteString + -> TPS.Step TermDoc a +stepParserBS p d inp = TPS.feed inp $ stepParser + (fmap prettyTerm) + (why prettyTerm) + (TPM.release d *> p) + mempty + True + mempty + mempty + -- | Just like ident but without the "lexeme $" prefix -- -- belongs in Text.Trifecta.Parser.Identifier @@ -23,4 +51,29 @@ identNL s = try $ do -- | Just like "pure" but right here in the parsing state -- -- belongs in Text.Trifecta.Diagnostic.Rendering.Span +pureSpanned :: MonadParser f => a -> f (Spanned a) pureSpanned r = (liftA (r :~) $ Span <$> position <*> position <*> line) + + +-- | A multi-line interaction mechanism, for the REPL. +-- +-- Maybe this should not be contributed, but it uses so much of the +-- internals that it surely belongs here beside the other such. +triInteract :: (Monad m, Show a) + => (forall m' . MonadParser m' => m' a) -- ^ Parser + -> (m (Maybe String)) -- ^ Continuation callback + -> (a -> m ()) -- ^ Success callback + -> (Q.Seq (Diagnostic TermDoc) -> m ()) -- ^ Failure callback + -> String -- ^ Initial input + -> m () +triInteract p c s f i = loop (stepParserBS p dd $ BU.fromString i) + where + loop x = traceShow ("triInteract", x) $ case x of + TPS.StepDone _ _ a -> s a + TPS.StepFail _ sd -> f sd + TPS.StepCont ro re k -> case re of + Success _ a -> s a + Failure sd -> c >>= maybe (f sd) (loop . k . R.snoc ro) + + dd = Directed (BU.fromString "interactive") 0 0 0 0 + -- 2.50.1