From 704c8e581de52723ddb9002d0d7455901d18a818 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Wed, 12 Dec 2012 16:44:00 -0500 Subject: [PATCH] Code shuffling for debugging backends --- bin/utils.py | 2 +- src/Dyna/Analysis/ANF.hs | 14 ++++++------- src/Dyna/Backend/Debugging.hs | 39 +++++++++++++++++++++++++++++++++++ src/Dyna/Backend/Python.hs | 37 +++++++-------------------------- src/Dyna/XXX/Trifecta.hs | 33 ++++++++++++++++++++--------- 5 files changed, 78 insertions(+), 47 deletions(-) create mode 100644 src/Dyna/Backend/Debugging.hs diff --git a/bin/utils.py b/bin/utils.py index 1d27421..3f164c3 100644 --- a/bin/utils.py +++ b/bin/utils.py @@ -9,7 +9,7 @@ def toANF(code, f='/tmp/tmp.dyna'): with file(f, 'wb') as tmp: tmp.write(code) os.system('rm -f %s.anf' % f) # clean up any existing ANF output - assert 0 == os.system("""ghc -isrc Dyna.Backend.Python -e 'normalizeFile "%s"' """ % f), \ + assert 0 == os.system("""ghc -isrc Dyna.Backend.Debugging -e 'normalizeFile "%s"' """ % f), \ 'failed to convert file.' with file('%s.anf' % f) as h: return h.read() diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 66e7dd2..bde6892 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -92,7 +92,7 @@ import Dyna.XXX.PPrint (valign) import qualified Data.Char as C -import Dyna.XXX.Trifecta (renderSpan) +import Dyna.XXX.Trifecta (prettySpanLoc) ------------------------------------------------------------------------}}} -- Preliminaries {{{ @@ -346,7 +346,7 @@ normTerm_ c ss (P.TFunctor f as) = do x@(NTVar v) | v `elem` vs -> do v' <- newAssign "_x" (Left x) return (vs,v':r) - x@(NTVar v) -> do + NTVar v -> do return (v:vs,v:r) _ -> do v' <- newAssignNT "_x" x @@ -404,19 +404,19 @@ runNormalize = ------------------------------------------------------------------------}}} -- Pretty Printer {{{ -printANF :: FRule -> Doc T.Effect +printANF :: FRule -> Doc e printANF (FRule h a s result span (AS {as_evals = evals, as_assgn = assgn, as_unifs = unifs})) = - --";;" <+> (renderSpan span) `above` - ( - parens $ (pretty a) + text ";;" <+> prettySpanLoc span + `above` + ( parens $ (pretty a) <+> valign [ (pretty h) , parens $ text "side" <+> (valign $ map pretty s) , parens $ text "evals" <+> pev , parens $ text "unifs" <+> pun , parens $ text "result" <+> (pretty result) ] - ) + ) <> line where pft :: FDT -> Doc e pft (fn,args) = parens $ hsep $ (pretty fn : (map pretty args)) diff --git a/src/Dyna/Backend/Debugging.hs b/src/Dyna/Backend/Debugging.hs new file mode 100644 index 0000000..eaa69d1 --- /dev/null +++ b/src/Dyna/Backend/Debugging.hs @@ -0,0 +1,39 @@ +--------------------------------------------------------------------------- +-- | A variety of debugging backends. +-- +-- XXX Eventually, these may want such things kicked on by flags rather +-- than invoked directly. + +-- Header material {{{ +module Dyna.Backend.Debugging where + +import Control.Applicative ((<*)) +import Control.Exception +import Dyna.Analysis.ANF +import qualified Dyna.ParserHS.Parser as P +import System.IO +import Text.PrettyPrint.Free as PP +import qualified Text.Trifecta as T + +------------------------------------------------------------------------}}} +-- File to ANF {{{ + +-- | Normalize all the rules in a file and emit S-exprs for the ANF +-- normalized form. +-- +-- NOTE: This is used by bin/prototype.py +normalizeFile_ file oh = do + pr <- T.parseFromFileEx (P.dlines <* T.eof) file + case pr of + T.Failure td -> T.display td + T.Success rs -> mapM_ (PP.hPutDoc oh) + $ map (\(P.LRule x T.:~ _) -> printANF $ normRule x) rs + +normalizeFile i o = bracket + (openFile o WriteMode) + (hClose) + $ normalizeFile_ i + +normalizeFileStdout file = normalizeFile_ file stdout + +------------------------------------------------------------------------}}} diff --git a/src/Dyna/Backend/Python.hs b/src/Dyna/Backend/Python.hs index 780e7ff..61d22f8 100644 --- a/src/Dyna/Backend/Python.hs +++ b/src/Dyna/Backend/Python.hs @@ -12,8 +12,7 @@ module Dyna.Backend.Python where -import Control.Applicative ((<*)) - +import Control.Applicative ((<*)) import qualified Control.Arrow as A import Control.Exception import Control.Monad @@ -40,7 +39,7 @@ import System.IO import Text.PrettyPrint.Free import qualified Text.Trifecta as T -import Dyna.XXX.Trifecta (renderSpan) +import Dyna.XXX.Trifecta (prettySpanLoc) ------------------------------------------------------------------------}}} @@ -174,27 +173,22 @@ printPlan :: Handle printPlan fh fa mu (r, cost, dope) = do -- display plan hPutStrLn fh $ "# --" displayIO fh $ prefixSD "# " $ renderPretty 1.0 100 - $ (renderSpan $ fr_span r) <> line + $ (prettySpanLoc $ fr_span r) <> line hPutStrLn fh $ "# Cost: " ++ (show cost) displayIO fh $ renderPretty 1.0 100 $ py fa mu r dope <> line hPutStrLn fh "" - - -processFile fileName = do - fh <- openFile (fileName ++ ".plan") WriteMode - processFile_ fileName fh - hClose fh - +processFile fileName = bracket + (openFile (fileName ++ ".plan") WriteMode) + hClose + $ processFile_ fileName processFileStdout fileName = do processFile_ fileName stdout - processFile_ fileName fh = do pr <- T.parseFromFileEx (P.dlines <* T.eof) fileName - case pr of T.Failure td -> T.display td T.Success rs -> @@ -236,21 +230,6 @@ processFile_ fileName fh = do valVar = "_v" --- TEST: processFile "examples/cky.dyna" - -------------------------------------------------------------------------}}} --- Experimental Residuals? {{{ +-- TEST: processFileStdout "examples/cky.dyna" --- | Normalize all the rules in a file and emit S-exprs for the ANF --- normalized form. --- --- NOTE: This is used by bin/prototype.py -normalizeFile file = do - contents <- B.readFile file - writeFile (file ++ ".anf") - (show $ vcat (map (\(P.LRule x T.:~ _) -> - printANF $ normRule x) - (unsafeParse P.dlines contents)) - <> line) - return () ------------------------------------------------------------------------}}} diff --git a/src/Dyna/XXX/Trifecta.hs b/src/Dyna/XXX/Trifecta.hs index a6ba7ab..113ef5d 100644 --- a/src/Dyna/XXX/Trifecta.hs +++ b/src/Dyna/XXX/Trifecta.hs @@ -2,8 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} -- XXX contribute back to trifecta +-- Header material {{{ module Dyna.XXX.Trifecta ( - identNL, pureSpanned, stringLiteralSQ, triInteract, renderSpan + identNL, pureSpanned, stringLiteralSQ, triInteract, prettySpanLoc ) where import Control.Applicative @@ -18,10 +19,13 @@ import Text.Parser.Token.Highlight import Text.Trifecta import Text.Trifecta.Delta -import Text.PrettyPrint.Free ((<+>), above, indent) +import qualified Text.PrettyPrint.Free as PP -- import Debug.Trace +------------------------------------------------------------------------}}} +-- identNL {{{ + -- | Just like ident but without the "token $" prefix -- -- belongs in Text.Parser.Token @@ -32,6 +36,9 @@ identNL s = try $ do when (HashSet.member name (styleReserved s)) $ unexpected $ "reserved " ++ styleName s ++ " " ++ show name return name +------------------------------------------------------------------------}}} +-- String literal variants {{{ + -- | Just like stringLiteral but with single quotes. -- -- belongs in Text.Parser.Token @@ -87,6 +94,8 @@ number :: TokenParsing m => Integer -> m Char -> m Integer number base baseDigit = foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 <$> some baseDigit +------------------------------------------------------------------------}}} +-- pureSpanned {{{ -- | Just like "pure" but right here in the parsing state -- @@ -94,6 +103,8 @@ number base baseDigit = pureSpanned :: DeltaParsing m => a -> m (Spanned a) pureSpanned r = (liftA (r :~) $ Span <$> position <*> position <*> line) +------------------------------------------------------------------------}}} +-- Interaction {{{ -- | A multi-line interaction mechanism, for the REPL. -- @@ -119,11 +130,13 @@ triInteract p c s f i = loop (feed (BU.fromString i) $ stepParser (release dd *> ------------------------------------------------------------------------}}} --- Utilities {{{ - -renderSpan (Span s e bs) = - prettyTerm s - <+> "-" - <+> prettyTerm e - <+> ":" - `above` (indent 2 (prettyTerm $ rendering s bs)) +-- Diagnostic utilities {{{ + +-- XXX I'd really like (but cannot seem to get) the ability to suppress the +-- file name if it's the same in both cases. Stripping Directed to Lines +-- results in the lie of "(interactive)". In any case, this function is +-- here as a placeholder for doing the right thing. +prettySpanLoc :: Span -> PP.Doc e +prettySpanLoc (Span s e l) = PP.pretty s PP.<> PP.char '-' PP.<> PP.pretty e + +------------------------------------------------------------------------}}} -- 2.50.1