*.o
*.pyc
-examples/*.plan
-examples/*.anf
-examples/*.d
+dist/
cabal build
cabal test
+# If the cabal file doesn't do the right thing, this tries to work through
+# it all by hand. Blech! But it's better than nothing.
+ghcbuild:
+ mkdir -p dist/build/dyna/
+ mkdir -p dist/build/dyna/dyna-tmp
+ ghc --make -isrc \
+ -o dist/build/dyna/dyna \
+ -outputdir dist/build/dyna/dyna-tmp \
+ -main-is Dyna.Main.Driver Dyna.Main.Driver
+
+ mkdir -p dist/build/dyna-selftests
+ mkdir -p dist/build/dyna-selftests/dyna-selftests-tmp
+ ghc --make -isrc \
+ -o dist/build/dyna-selftests/dyna-selftests \
+ -outputdir dist/build/dyna-selftests/dyna-selftests-tmp \
+ -main-is Dyna.Main.TestsDriver Dyna.Main.TestsDriver
+
+tests:
+ dist/build/dyna-selftests/dyna-selftests
+
run-parser:
ghci -isrc Dyna.ParserHS.Parser
+
+.PHONY: clean veryclean
+clean:
+ rm -rf examples/*.dyna.plan examples/*.dyna.d
+veryclean: clean
+ rm -rf dist
+++ /dev/null
-An overview of the source tree
-------------------------------
-
-external/
- damsl-k3 -- The DAMSL K3 tree, tracked as a git submodule.
-
- ekmett-parsers -- ekmett's parsers combinator library, tracked
- -- as a git submodule.
-
- ekmett-trifecta -- ekmett's trifecta parser combinator library,
- -- tracked as a git submodule.
-
-src/Dyna/
-
- BackendK3 -- An AST and printer for K3,
- -- done in finally-tagless style.
- -- Includes some "Examples", even if not self-tests.
-
- Backend -- Compilation to target languages
-
- Main -- Dyna compiler main modules
-
- ParserHS -- the Haskell front-end parser and selftests
-
- Term -- Different representations of terms and
- -- utilities
-
- Test -- code used by self-tests throughout the codebase
- -- and the top-level test harness itself
-
- XXX -- code that should probably go upstream;
- -- modules here are named by the upstream package.
-
-
-Building
---------
-
-First, ensure that you have GHC 7.6 or later. (Though in a pinch, if you're
-only interested in the frontend stuff, apparently as early as 7.0 continues
-to be servicable.)
-
-Then, sadly, I have to ask you to build some upstream packages out of their
-repositories. I thought they were going to be released "soon" when I
-switched to these later versions, but it hasn't happened yet:
-
-make upstream
-
-Build K3, which requires OCaml:
-
-git submodule update external/damsl-k3
-(cd external/damsl-k3; make)
-
-Then fetch, build, and install any dependencies
-
-make deps
-
-Build Dyna:
-
-make build
-
-And then run the REPL:
-
-./dist/build/drepl/drepl
-
-OK, that last bit is probably not quite true. At this point, the code is
-still rather "in the works" so you probably want to load some module in
-GHCi; for example:
-
-ghci -isrc Dyna.ParserHS.Parser
-
-Disclaimer
-----------
-
-This may someday be useful. For the moment, it doesn't do much except keep
-us busy. If you're trying to make it do something and it breaks, you get to
-keep all the pieces; see sections 15 - 17 of the AGPLv3 (available in
-LICENSE).
--- /dev/null
+An overview of the source tree
+------------------------------
+
+* examples/ -- Dyna source programs
+ * expected/ -- Expected output for self-tests. Named by program and backend, both.
+* external/
+ * damsl-k3 -- The DAMSL K3 tree, tracked as a git submodule.
+ * ekmett-parsers -- ekmett's parsers combinator library, tracked as a git submodule.
+ * ekmett-trifecta -- ekmett's trifecta parser combinator library, tracked as a git submodule.
+* src/Dyna/
+ * Backend
+ * K3 -- An AST and printer for K3, done in finally-tagless style.
+ * Python -- A Python code generator
+ * Backend -- Compilation to target languages
+ * Main -- Dyna compiler drivers (main and test) and definitions used throughout the pipeline
+ * ParserHS -- the Haskell front-end parser and selftests
+ * Term -- Different representations of terms and utilities
+ * XXX -- code that should probably go upstream; modules here are named by the upstream package.
+
+Building
+--------
+
+First, ensure that you have GHC 7.6 or later. (Though in a pinch, if you're
+only interested in the frontend stuff and the Python backend, apparently as
+early as 7.0 continues to be servicable.)
+
+Then, sadly, I have to ask you to build some upstream packages out of their
+repositories. I thought they were going to be released "soon" when I
+switched to these later versions, but it hasn't happened yet:
+
+ make upstream
+
+Build K3, if that's your thing, which requires OCaml:
+
+ git submodule update external/damsl-k3
+ (cd external/damsl-k3; make)
+
+Then fetch, build, and install any dependencies
+
+ make deps
+
+Build Dyna:
+
+ make build
+
+(If that doesn't work, you might try `make ghcbuild` which ignores the Cabal
+infrastructure.)
+
+Run the test harness:
+
+ make tests
+
+And then run the REPL:
+
+ ./dist/build/drepl/drepl
+
+OK, that last bit is probably not quite true. At this point, the code is
+still rather "in the works" so you probably want to...
+
+* load some module in GHCi; for example:
+
+ ghci -isrc Dyna.ParserHS.Parser
+
+* Run the python backend interactively (leave off the "-i" for bulk
+operation):
+
+ ./dyna -i examples/papa2.dyna
+
+* Produce visualizations of some of the internal stages of our compiler
+
+ ./debug examples/papa2.dyna
+
+Disclaimer
+----------
+
+This may someday be useful. For the moment, it doesn't do much except keep
+us busy. If you're trying to make it do something and it breaks, you get to
+keep all the pieces; see sections 15 - 17 of the AGPLv3 (available in
+LICENSE).
except KeyboardInterrupt:
pass
finally:
- dump_charts()
if argv.output is not None:
- with file(argv.output, 'wb') as f:
- dump_charts(f)
+ if argv.output == "-": dump_charts(sys.stdout)
+ else:
+ with file(argv.output, 'wb') as f: dump_charts(f)
+ else: dump_charts()
def dynac(f):
- cmd = """ghc -isrc Dyna.Backend.Python -e 'processFile "%s"' """ % f
+ cmd = """dist/build/dyna/dyna -B python -o "%s".plan "%s" """ % (f,f)
assert 0 == os.system(cmd), 'command failed:\n\t' + cmd
return f + '.plan'
print >> html, '<h2>Update plans</h2>'
- cmd = """ghc -isrc Dyna.Backend.Python -e 'processFile "%s"' """ % dynafile
+ cmd = """dist/build/dyna/dyna -B python -o "%s".plan "%s" """ % (dynafile,dynafile)
if 0 != os.system(cmd):
print 'command failed:\n\t' + cmd
os.system('gnome-open %s 2>/dev/null >/dev/null' % html.name)
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.Debugging -e 'normalizeFile "%s"' """ % f), \
+ assert 0 == os.system("""dist/build/dyna/dyna --dump-anf="%s".anf --backend=none \"%s\" """ % (f,f)), \
'failed to convert file.'
with file('%s.anf' % f) as h:
return h.read()
Executable drepl
Default-Language: Haskell2010
+ Hs-Source-Dirs: src
ghc-options: -Wall
-main-is Dyna.REPL
- Hs-Source-Dirs: src
Build-Depends: base >=4,
bytestring >=0.9,
charset >=0.3,
Main-Is: Dyna/REPL.hs
+Executable dyna
+
+ Default-Language: Haskell2010
+ Hs-Source-Dirs: src
+
+ ghc-options: -Wall
+ -main-is Dyna.Main.Driver
+
+ Build-Depends: base >=4,
+ bytestring >=0.9,
+ charset >=0.3,
+ containers >=0.4,
+ haskeline >=0.6,
+ HUnit >=1.2,
+ mtl >=2.1,
+ parsers >=0.2,
+ process >=1.1,
+ reducers >=3.0,
+ semigroups >=0.8,
+ tagged >= 0.4.4,
+ trifecta >=0.90,
+ unification-fd,
+ unordered-containers>=0.2,
+ utf8-string >=0.3,
+ wl-pprint-extras >=3.0,
+ wl-pprint-terminfo >=3.0
+
+ Main-Is: Dyna/Main/Driver.hs
+
Test-suite dyna-selftests
type: exitcode-stdio-1.0
Default-Language: Haskell2010
Hs-Source-Dirs: src
ghc-options: -Wall
- -main-is Dyna.Test.Main
+ -main-is Dyna.Main.TestsDriver
Build-Depends: base >=4,
bytestring >=0.9,
HUnit >=1.2,
mtl >=2.1,
parsers >=0.2,
+ process >=1.1,
reducers >=3.0,
semigroups >=0.8,
tagged >= 0.4.4,
test-framework >=0.6,
test-framework-hunit >=0.2,
test-framework-th >=0.2,
+ test-framework-golden >= 1.1,
trifecta >=0.90,
unification-fd,
unordered-containers>=0.2,
Other-Modules: Dyna.Backend.K3.Examples
- Main-Is: Dyna/Test/Main.hs
+ Main-Is: Dyna/Main/TestsDriver.hs
--- /dev/null
+
+Charts
+============
+best/0
+=================
+best := pair(1,t('S',t('S',t('NP','Papa'),t('VP',t('VP',t('V','ate'),t('NP',t('Det','the'),t('N','caviar'))),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon'))))),'.'))
+
+bestParse/0
+=================
+bestParse := t('S',t('S',t('NP','Papa'),t('VP',t('VP',t('V','ate'),t('NP',t('Det','the'),t('N','caviar'))),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon'))))),'.')
+
+bestScore/0
+=================
+bestScore := 1
+
+goal/1
+=================
+goal(t('S',t('S',t('NP','Papa'),t('VP',t('V','ate'),t('NP',t('NP',t('Det','the'),t('N','caviar')),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon')))))),'.')) := 1
+goal(t('S',t('S',t('NP','Papa'),t('VP',t('VP',t('V','ate'),t('NP',t('Det','the'),t('N','caviar'))),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon'))))),'.')) := 1
+
+length/0
+=================
+length := 8
+
+pair/2
+=================
+
+
+phrase/4
+=================
+phrase('.',7,8,'.') := 1
+phrase('Det',2,3,t('Det','the')) := 1
+phrase('Det',5,6,t('Det','a')) := 1
+phrase('N',3,4,t('N','caviar')) := 1
+phrase('N',6,7,t('N','spoon')) := 1
+phrase('NP',0,1,t('NP','Papa')) := 1
+phrase('NP',2,4,t('NP',t('Det','the'),t('N','caviar'))) := 1
+phrase('NP',2,7,t('NP',t('NP',t('Det','the'),t('N','caviar')),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon'))))) := 1
+phrase('NP',5,7,t('NP',t('Det','a'),t('N','spoon'))) := 1
+phrase('P',4,5,t('P','with')) := 1
+phrase('PP',4,7,t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon')))) := 1
+phrase('Papa',0,1,'Papa') := 1
+phrase('S',0,4,t('S',t('NP','Papa'),t('VP',t('V','ate'),t('NP',t('Det','the'),t('N','caviar'))))) := 1
+phrase('S',0,7,t('S',t('NP','Papa'),t('VP',t('VP',t('V','ate'),t('NP',t('Det','the'),t('N','caviar'))),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon')))))) := 1
+phrase('S',0,7,t('S',t('NP','Papa'),t('VP',t('V','ate'),t('NP',t('NP',t('Det','the'),t('N','caviar')),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon'))))))) := 1
+phrase('S',0,8,t('S',t('S',t('NP','Papa'),t('VP',t('V','ate'),t('NP',t('NP',t('Det','the'),t('N','caviar')),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon')))))),'.')) := 1
+phrase('S',0,8,t('S',t('S',t('NP','Papa'),t('VP',t('VP',t('V','ate'),t('NP',t('Det','the'),t('N','caviar'))),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon'))))),'.')) := 1
+phrase('V',1,2,t('V','ate')) := 1
+phrase('VP',1,4,t('VP',t('V','ate'),t('NP',t('Det','the'),t('N','caviar')))) := 1
+phrase('VP',1,7,t('VP',t('VP',t('V','ate'),t('NP',t('Det','the'),t('N','caviar'))),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon'))))) := 1
+phrase('VP',1,7,t('VP',t('V','ate'),t('NP',t('NP',t('Det','the'),t('N','caviar')),t('PP',t('P','with'),t('NP',t('Det','a'),t('N','spoon')))))) := 1
+phrase('a',5,6,'a') := 1
+phrase('ate',1,2,'ate') := 1
+phrase('caviar',3,4,'caviar') := 1
+phrase('spoon',6,7,'spoon') := 1
+phrase('the',2,3,'the') := 1
+phrase('with',4,5,'with') := 1
+
+rewrite/2
+=================
+rewrite('Det','a') := 1
+rewrite('Det','the') := 1
+rewrite('N','caviar') := 1
+rewrite('N','spoon') := 1
+rewrite('NP','Papa') := 1
+rewrite('P','with') := 1
+rewrite('V','ate') := 1
+
+rewrite/3
+=================
+rewrite('NP','Det','N') := 1
+rewrite('NP','NP','PP') := 1
+rewrite('PP','P','NP') := 1
+rewrite('S','NP','VP') := 1
+rewrite('S','S','.') := 1
+rewrite('VP','V','NP') := 1
+rewrite('VP','VP','PP') := 1
+
+t/2
+=================
+
+
+t/3
+=================
+
+
+word/2
+=================
+word('.',7) := True
+word('Papa',0) := True
+word('a',5) := True
+word('ate',1) := True
+word('caviar',3) := True
+word('spoon',6) := True
+word('the',2) := True
+word('with',4) := True
+
--- /dev/null
+
+Charts
+============
+a/0
+=================
+a := True
+
+b/0
+=================
+b := True
+
+c/0
+=================
+c := True
+
Crux(..),
- Action, Cost, Det(..), planInitializer, planEachEval,
+ Action, Cost, Det(..), planInitializer,
+ BackendPossible, planEachEval,
+
+ EvalMap, combinePlans,
adornedQueries
) where
import Dyna.Term.TTerm
import Dyna.Main.Exception
import qualified Dyna.ParserHS.Parser as DP
-import Dyna.XXX.DataUtils(argmin)
+import Dyna.XXX.DataUtils(argmin,mapInOrApp)
+import Dyna.XXX.Trifecta (prettySpanLoc)
import Dyna.XXX.TrifectaTest
+import Text.PrettyPrint.Free
------------------------------------------------------------------------}}}
-- Modes {{{
go [] [] = []
go (r:rs) [] = go rs r
go rs (p:ps) = case stepPartialPlan st sc mic p of
- Left df -> df : (go rs ps)
+ Left df -> (\(c,a) -> (c,fmap (\(_,x,y) -> (x,y)) mic,a)) df
+ : (go rs ps)
Right ps' -> go (ps':rs) ps
-- XXX we're going to need to initially plan a unification crux as part of
-- backward chaining, but we don't yet.
-initializeForCrux :: (Crux DVar a, DVar, DVar)
+initializeForCrux :: (Crux DVar a)
-> ((DFunctAr, DVar, DVar), Action fbs)
-initializeForCrux (cr, hi, v) = case cr of
- CFCall o is f -> ( ((f,length is), hi, o)
- , [ OPPeel is hi f, OPAsgn o (NTVar v) ])
+initializeForCrux cr = case cr of
+ CFCall o is f -> ( ((f,length is), _hi, o)
+ , [ OPPeel is _hi f ])
_ -> dynacSorry "Don't know how to initially plan !CFCall"
+ where
+ _hi = "_i"
-- | Given a normalized form and an initial crux, saturate the graph and
-- get a plan for doing so.
plan_ :: Possible fbs -- ^ Available steps
-> (PartialPlan fbs -> Action fbs -> Cost) -- ^ Scoring function
-> ANFState -- ^ Normal form
- -> Maybe (Crux DVar NTV, DVar, DVar) -- ^ Initial crux,
- -- item intern, and
- -- value, if any.
- -> [(Cost, Action fbs)] -- ^ If there's a plan...
+ -> Maybe (Crux DVar NTV) -- ^ Initial crux
+ -> [(Cost, Maybe (DVar,DVar), Action fbs)] -- ^ If there's a plan...
plan_ st sc anf mi =
let cruxes = eval_cruxes anf
++ unif_cruxes anf
(mic,ip) = maybe (Nothing, []) (first Just . initializeForCrux) mi
- initPlan = PP { pp_cruxes = maybe id (\(c,_,_) -> S.delete c) mi
- $ S.fromList cruxes
- , pp_binds = maybe S.empty (\(c,_,_) -> cruxVars c) mi
+ initPlan = PP { pp_cruxes = maybe id S.delete mi $ S.fromList cruxes
+ , pp_binds = maybe S.empty cruxVars mi
, pp_restrictSearch = False
, pp_score = 0
, pp_plan = ip
plan :: Possible fbs
-> (PartialPlan fbs -> Action fbs -> Cost)
-> ANFState
- -> Maybe (Crux DVar NTV, DVar, DVar)
- -> Maybe (Cost, Action fbs)
+ -> Maybe (Crux DVar NTV)
+ -> Maybe (Cost, Maybe (DVar,DVar), Action fbs)
plan st sc anf mi =
(\x -> case x of
[] -> Nothing
- plans -> Just $ argmin fst plans)
+ plans -> Just $ argmin (\(c,_,_) -> c) plans)
$ plan_ st sc anf mi
-planInitializer :: BackendPossible fbs -> Rule -> Maybe (Cost,Action fbs)
-planInitializer bp (Rule { r_anf = anf }) = plan (possible bp)
- simpleCost anf Nothing
-
-planEachEval :: BackendPossible fbs
- -> S.Set DFunctAr
- -> DVar -> DVar -> Rule -> [(DFunctAr, Maybe (Cost,Action fbs))]
-planEachEval bp cs hi v (Rule { r_anf = anf }) =
- map (\(c,fa) -> (fa, plan (possible bp) simpleCost anf $ Just (c,hi,v)))
+planInitializer :: BackendPossible fbs -> Rule -> Maybe (Cost, Action fbs)
+planInitializer bp (Rule { r_anf = anf }) =
+ fmap (\(c,m,a) -> case m of
+ Nothing -> (c,a)
+ Just _ -> dynacPanic "Initializer wants input variables?")
+ $ plan (possible bp) simpleCost anf Nothing
+
+planEachEval :: BackendPossible fbs -- ^ The backend's primitive support
+ -> (DFunctAr -> Bool) -- ^ Indicator for constant function
+ -> Rule
+ -> [(DFunctAr, Maybe (Cost, Maybe (DVar, DVar), Action fbs))]
+planEachEval bp cs (Rule { r_anf = anf }) =
+ map (\(c,fa) -> (fa, plan (possible bp) simpleCost anf $ Just c))
$ MA.mapMaybe (\c -> case c of
- CFCall _ is f | S.notMember (f,length is) cs
+ CFCall _ is f | cs (f,length is)
-> Just $ (c,(f,length is))
_ -> Nothing )
$ eval_cruxes anf
+------------------------------------------------------------------------}}}
+-- Plan combination {{{
+
+type EvalMap fbs = M.Map DFunctAr [(Rule, Cost, Maybe (DVar,DVar), Action fbs)]
+
+-- | Return all plans for each functor/arity
+--
+-- XXX This may still belong elsewhere.
+--
+-- XXX This guy wants span information; he's got it now use it.
+--
+-- timv: might want to fuse these into one circuit
+--
+combinePlans :: [(Rule,[(DFunctAr, Maybe (Cost, Maybe (DVar, DVar), Action fbs))])]
+ -> EvalMap fbs
+combinePlans = go (M.empty)
+ where
+ go m [] = m
+ go m ((fr,cmca):xs) = go' xs fr cmca m
+
+ go' xs _ [] m = go m xs
+ go' xs fr ((fa,mca):ys) m =
+ case mca of
+ Nothing -> dynacUserErr
+ $ "No update plan for "
+ <+> (pretty fa)
+ <+> "in rule at"
+ <+> (prettySpanLoc $ r_span fr)
+ Just (c,mv,a) -> go' xs fr ys $ mapInOrApp fa (fr,c,mv,a) m
+
------------------------------------------------------------------------}}}
-- Adorned Queries {{{
+++ /dev/null
----------------------------------------------------------------------------
--- | 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 = bracket
- (openFile (i++".anf") WriteMode)
- (hClose)
- $ normalizeFile_ i
-
-normalizeFileStdout file = normalizeFile_ file stdout
-
-------------------------------------------------------------------------}}}
---------------------------------------------------------------------------
-- | Compile to Python
--
--- See bin/stdlib.py
+-- See bin/interpreter.py
-- Header material {{{
{-# LANGUAGE OverloadedStrings #-}
-module Dyna.Backend.Python where
+module Dyna.Backend.Python (pythonBackend) where
import Control.Applicative ((<*))
import qualified Control.Arrow as A
import Dyna.Analysis.Base
import Dyna.Analysis.Aggregation
import Dyna.Analysis.RuleMode
+import Dyna.Main.BackendDefn
import Dyna.Main.Exception
import Dyna.Term.TTerm
import qualified Dyna.ParserHS.Parser as P
------------------------------------------------------------------------}}}
-- DOpAMine Backend Information {{{
-constants = S.fromList
- [ ("+",2)
- , ("-",2)
- , ("-",1) -- unary negation
- , ("*",2)
- , ("/",2)
- , ("^",2)
- , ("&",2)
- , ("|",2)
- , ("%",2)
- , ("**",2)
- , ("<",2)
- , ("<=",2)
- , (">",2)
- , (">=",2)
- , ("!",1)
- , ("mod",1)
- , ("abs",1)
- , ("log",1)
- , ("exp",1)
- , ("and",2)
- , ("or",2)
- , ("not",1)
- , ("eval",1)
- , ("true",0)
- , ("false",0)
- , ("null",0) -- XXX is this right?
- ]
-
data PyDopeBS = PDBAsIs
| PDBRewrite (([ModedVar],ModedVar) -> [DOpAMine PyDopeBS])
-builtin (f,is,o) = case () of
+builtins (f,is,o) = case () of
_ | all (== MBound) is && S.member (f,length is) constants
-> case o of
MFree -> Right (Det,PDBAsIs)
_ | S.member (f,length is) constants -> Left True
_ -> Left False
+-- XXX This and pycall ought to be merged
+constants :: S.Set (DFunct,Int)
+constants = S.fromList
+ [ ("+",2)
+ , ("-",2)
+ , ("-",1) -- unary negation
+ , ("*",2)
+ , ("/",2)
+ , ("^",2)
+ , ("&",2)
+ , ("|",2)
+ , ("%",2)
+ , ("**",2)
+ , ("<",2)
+ , ("<=",2)
+ , (">",2)
+ , (">=",2)
+ , ("!",1)
+ , ("mod",1)
+ , ("abs",1)
+ , ("log",1)
+ , ("exp",1)
+ , ("and",2)
+ , ("or",2)
+ , ("not",1)
+ , ("eval",1)
+ , ("true",0)
+ , ("false",0)
+ , ("null",0) -- XXX is this right?
+ ]
+
------------------------------------------------------------------------}}}
-- DOpAMine Printout {{{
functorIndirect table f vs = table <> (brackets $ dquotes $ (pretty f <> "/" <> (text $ show $ length vs)))
-
pycall table f vs = case (f, length vs) of
( "*", 2) -> infixOp " * "
( "+", 2) -> infixOp " + "
pf f vs = pretty f <> (tupled $ map pretty vs)
-------------------------------------------------------------------------}}}
--- Experimental Detritus {{{
-
--- | Return all plans for each functor/arity
---
--- XXX This belongs elsewhere.
---
--- XXX This guy wants span information; he's got it now use it.
---
--- timv: might want to fuse these into one circuit
---
-combinePlans :: [(Rule,[(DFunctAr, Maybe (Cost,Action fbs))])] ->
- M.Map DFunctAr [(Rule, Cost, Action fbs)]
-combinePlans = go (M.empty)
- where
- go m [] = m
- go m ((fr,cmca):xs) = go' xs fr cmca m
-
- go' xs _ [] m = go m xs
- go' xs fr ((fa,mca):ys) m =
- case mca of
- Nothing -> throw $ UserProgramError
- $ "No update plan for "
- <+> (pretty fa)
- <+> "in rule at"
- <+> (prettySpanLoc $ r_span fr)
- Just (c,a) -> go' xs fr ys $ mapInOrApp fa (fr,c,a) m
-
py (f,a) mu (Rule _ h _ _ r span _) dope =
case mu of
Just (hv,v) ->
emit = "emit" <> tupled [pretty h, pretty r]
-
printPlan :: Handle
-> (DFunct,Int) -- ^ Functor & arity
- -> Maybe (DVar,DVar) -- ^ if update, input intern & value
- -> (Rule, Cost, Action PyDopeBS) -- ^ rule and plan
+ -- | rule, cost, input variables, and plan
+ -> (Rule, Cost, Maybe (DVar, DVar), Action PyDopeBS)
-> IO ()
-printPlan fh fa mu (r, cost, dope) = do -- display plan
+printPlan fh fa (r, cost, mu, dope) = do -- display plan
hPutStrLn fh $ "# --"
displayIO fh $ prefixSD "# " $ renderPretty 1.0 100
$ (prettySpanLoc $ r_span r) <> line
$ py fa mu r dope <> line
hPutStrLn 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 ->
- let urs = map (\(P.LRule x T.:~ _) -> x) rs
- frs = map normRule urs
- initializers = MA.mapMaybe (\(f,mca) -> (\(c,a) -> (f,c,a)) `fmap` mca)
- $ map (\x -> (x, planInitializer builtin x)) frs
- in do
- aggm <- case buildAggMap frs of
- Left e -> throw $ UserProgramError (text e)
- Right x -> return x
-
- hPutStrLn fh $ "agg_decl = {}"
- forM (M.toList aggm) $ \((f,a),v) -> do {
- hPutStrLn fh $ show $ "agg_decl" <> brackets (dquotes $ pretty f <> "/" <> pretty a)
- <+> equals <+> (dquotes $ pretty v)
- }
-
- cPlans <- return $! combinePlans -- crux plans
- $ map (\x -> (x, planEachEval builtin constants headVar valVar x)) frs
- forM_ (M.toList cPlans) $ \(fa, ps) -> do -- plans aggregated by functor/arity
- hPutStrLn fh ""
- hPutStrLn fh $ "# =============="
- hPutStrLn fh $ "# " ++ show fa
- forM_ ps $ printPlan fh fa (Just (headVar,valVar))
- hPutStrLn fh ""
- hPutStrLn fh $ "# =============="
- hPutStrLn fh $ "# Initializers"
- forM_ initializers $ \(f,c,a) -> printPlan fh (findHeadFA f) Nothing (f,c,a)
+------------------------------------------------------------------------}}}
+-- Driver {{{
+
+driver am em is fh = do
+ -- Aggregation mapping
+ hPutStrLn fh $ "agg_decl = {}"
+ forM (M.toList am) $ \((f,a),v) -> do
+ hPutStrLn fh $ show $ "agg_decl"
+ <> brackets (dquotes $ pretty f <> "/" <> pretty a)
+ <+> equals <+> (dquotes $ pretty v)
+
+ -- plans aggregated by functor/arity
+ forM_ (M.toList em) $ \(fa, ps) -> do
+ hPutStrLn fh ""
+ hPutStrLn fh $ "# =============="
+ hPutStrLn fh $ "# " ++ show fa
+ forM_ ps $ printPlan fh fa
+
+ hPutStrLn fh ""
+ hPutStrLn fh $ "# =============="
+ hPutStrLn fh $ "# Initializers"
+
+ forM_ is $ \(f,c,a) -> printPlan fh (findHeadFA f) (f,c,Nothing,a)
where
findHeadFA (Rule _ h _ _ _ _ (AS { as_assgn = as })) =
Just (Left _) -> error "NTVar head?"
Just (Right (f,a)) -> (f, length a)
- headVar = "_h"
- valVar = "_v"
-
+------------------------------------------------------------------------}}}
+-- Export {{{
--- TEST: processFileStdout "examples/cky.dyna"
+pythonBackend = Backend builtins constants driver
------------------------------------------------------------------------}}}
--- /dev/null
+---------------------------------------------------------------------------
+-- | Self-tests for the Python backend, mostly by running the generated
+-- code through the interpreter.
+
+-- Header material {{{
+module Dyna.Backend.Python.Selftest where
+
+import Control.Exception (throw)
+import qualified Data.ByteString.Lazy as BL
+import System.Exit (ExitCode(..))
+import System.IO
+import System.Process
+import qualified Test.Framework as TF
+import Test.Golden
+
+------------------------------------------------------------------------}}}
+-- Run Backend {{{
+
+runDynaPy :: String -> IO BL.ByteString
+runDynaPy f = do
+ devnull <- openFile "/dev/null" ReadWriteMode
+
+ (Nothing,Just so,Nothing,ph) <- createProcess $ CreateProcess
+ { cmdspec = RawCommand "/usr/bin/env"
+ ["python", "bin/interpreter.py", "-o", "-", f]
+ , cwd = Nothing
+ , env = Nothing
+ , std_in = UseHandle devnull
+ , std_out = CreatePipe
+ , std_err = UseHandle devnull
+ , close_fds = True
+ , create_group = False
+ }
+ bs <- BL.hGetContents so
+ ec <- waitForProcess ph
+ case ec of
+ ExitSuccess -> return bs
+ ExitFailure _ -> throw ec
+
+------------------------------------------------------------------------}}}
+-- Tests {{{
+
+mkExample :: String -> TF.Test
+mkExample name =
+ let (dy,ex) = names in goldenVsString dy ex (runDynaPy dy)
+ where
+ names = ( "examples/" ++ name ++ ".dyna"
+ , "examples/expected/" ++ name ++ ".py.out")
+
+goldens :: TF.Test
+goldens = TF.testGroup "Python Backend End-To-End"
+ $ map mkExample ["simple", "papa2"]
+
+------------------------------------------------------------------------}}}
+-- Harness toplevel {{{
+
+selftest :: TF.Test
+selftest = goldens
+
+main :: IO ()
+main = TF.defaultMain [selftest]
+
+-- If you're running from within GHCi and just want to do something quickly,
+-- try
+--
+-- TF.defaultMain [mkExample "simple"]
+
+------------------------------------------------------------------------}}}
--- /dev/null
+---------------------------------------------------------------------------
+-- | What does it mean to be a backend?
+
+-- Header material {{{
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Dyna.Main.BackendDefn where
+
+import qualified Data.Set as S
+import Dyna.Analysis.Aggregation (AggMap)
+import Dyna.Analysis.ANF (Rule)
+import Dyna.Analysis.RuleMode (Action, BackendPossible, Cost, EvalMap)
+import Dyna.Term.TTerm (DFunctAr)
+import System.IO (Handle)
+
+-- XXX The notion of be_constants is not quite right, I think? It is used
+-- only in Dyna.Analysis.RuleMode.planEachEval to avoid generating some
+-- plans, but that's not really how we should be doing it. The right
+-- answer, of course, is to use update mode information, once we have it.
+
+data Backend = forall bs . Backend
+ { -- | Builtin support hook for mode planning. Options are
+ -- to return
+ --
+ -- * @Left False@ -- This functor is not built in
+ --
+ -- * @Left True@ -- There is no plan for this mode
+ --
+ -- * @Right (d,b)@ -- There is a plan here with determinism
+ -- @d@ and backend-specific data @b@.
+ be_builtin :: BackendPossible bs
+
+ -- | Any constants made available by this backend.
+ , be_constants :: S.Set DFunctAr
+
+ -- | Backend driver
+ , be_driver :: AggMap -- ^ Aggregation
+ -> EvalMap bs -- ^ Rules
+ -> [(Rule,Cost,Action bs)] -- ^ Initializers
+ -> Handle -- ^ Output
+ -> IO ()
+ }
--- /dev/null
+---------------------------------------------------------------------------
+-- | Main driver of the pipeline
+
+-- Header material {{{
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ImplicitParams #-} -- This is probably a terrible idea, but
+ -- I'd never done it before and wanted to
+ -- see what it's like. It won't be hard to
+ -- rip out.
+{-# LANGUAGE OverloadedStrings #-}
+
+module Dyna.Main.Driver where
+
+import Control.Applicative ((<*))
+import Control.Exception
+import Control.Monad
+import Data.Char
+import qualified Data.Map as M
+import qualified Data.Maybe as MA
+import qualified Data.Set as S
+import Dyna.Analysis.Aggregation
+import Dyna.Analysis.ANF
+import Dyna.Analysis.RuleMode
+import Dyna.Backend.Python
+import Dyna.Main.BackendDefn
+import Dyna.Main.Exception
+import qualified Dyna.ParserHS.Parser as P
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+import System.IO
+import Text.PrettyPrint.Free
+import qualified Text.Trifecta as T
+
+------------------------------------------------------------------------}}}
+-- Dumping {{{
+
+data DumpType = DumpAgg
+ | DumpANF
+ | DumpParsed
+ deriving (Eq,Ord,Show)
+
+type DumpMap = M.Map DumpType (Maybe FilePath)
+
+dump :: (?dcfg :: DynacConfig) => DumpType -> Doc e -> IO ()
+dump dt doc =
+ case M.lookup dt (dcfg_dumps ?dcfg) of
+ Nothing -> return ()
+ Just Nothing -> go True stderr
+ Just (Just f) -> bracket (openFile f WriteMode) hClose (go False)
+ where
+ go h f = hPutDoc f $
+ if h
+ then header `above` doc <> line <> line
+ <> hcat (replicate 4 bar) <> line
+ else doc
+
+ header = bar <+> fill 18 (text $ show dt) <+> bar
+ bar = "=========="
+
+anyDumpStderr :: (?dcfg :: DynacConfig) => Bool
+anyDumpStderr = M.foldr (\v r -> r || MA.isNothing v)
+ False (dcfg_dumps ?dcfg)
+
+------------------------------------------------------------------------}}}
+-- Backend {{{
+
+noBackend :: Backend
+noBackend = Backend
+ { be_builtin = \_ -> Left False
+ , be_constants = S.empty
+ , be_driver = \_ _ _ _ -> hPutStrLn stderr
+ "No backend specified; stopping"
+ }
+
+parseBackend :: String -> Backend
+parseBackend s = case map toLower s of
+ "none" -> noBackend
+ "python" -> pythonBackend
+ _ -> dynacThrow $ InvocationError
+ $ "Unknown backend:" <+> pretty s
+
+------------------------------------------------------------------------}}}
+-- DynacConfiguration {{{
+
+data DynacConfig = DynacConfig { dcfg_backend :: Backend
+ , dcfg_dumps :: DumpMap
+ , dcfg_outFile :: Maybe FilePath
+ }
+
+
+defaultDynacConfig :: DynacConfig
+defaultDynacConfig = DynacConfig
+ { dcfg_backend = noBackend
+ , dcfg_dumps = M.empty
+ , dcfg_outFile = Nothing
+ }
+
+------------------------------------------------------------------------}}}
+-- Options and Argument Handling {{{
+
+data Opt = OptVersion
+ | OptHelp
+ | OptBackend Backend
+ | OptDump (DumpMap -> DumpMap)
+ | OptOutput FilePath
+
+
+options :: [OptDescr Opt]
+options =
+ [ Option ['h'] ["help"] (NoArg OptHelp) "display this help message"
+ , Option ['V'] ["version"] (NoArg OptVersion) "display version and exit"
+ ]
+ ++
+ [ Option ['B'] ["backend"] (ReqArg obe "BE")
+ "use backend BE"
+ , Option ['o'] ["out","output"] (ReqArg OptOutput "FILE")
+ "write generated output to FILE"
+ ]
+ -- XXX we'd like these to not be documented, at least not by default, but
+ -- that would require patching the getopt library
+ ++ mkDumpOpt "agg" DumpAgg
+ ++ mkDumpOpt "anf" DumpANF
+ ++ mkDumpOpt "parse" DumpParsed
+ where
+ obe = OptBackend . parseBackend
+
+ mkDumpOpt arg fl =
+ [ Option [] ["dump-" ++ arg] (OptArg (OptDump . sfl) "FILE") ""
+ , Option [] ["no-dump-" ++ arg] (NoArg (OptDump cfl) ) ""
+ ]
+ where
+ sfl x fs = M.insert fl x fs
+ cfl fs = M.delete fl fs
+
+
+procArgs :: [String] -> IO (DynacConfig, [String])
+procArgs argv = do
+ case getOpt Permute options argv of
+ (os,as,[]) -> case foldOpts os of
+ Left x -> do
+ putStrLn "Dyna 0.4"
+ when x $ putStrLn (usageInfo "" options)
+ exitSuccess
+ Right f -> return $ (f defaultDynacConfig, as)
+ (_,_,es) -> dynacThrow $ InvocationError
+ $ vcat (map pretty es)
+ `above`
+ pretty (usageInfo "" options)
+ where
+ foldOpts :: [Opt] -> Either Bool (DynacConfig -> DynacConfig)
+ foldOpts = go id
+ where
+ go f [] = Right f
+ go _ (OptHelp:_) = Left True
+ go _ (OptVersion:_) = Left False
+ go f (OptBackend b:os) = go (setBackend b . f) os
+ go f (OptDump f':os) = go (mungeDump f' . f) os
+ go f (OptOutput fn:os) = go (setOutput fn . f) os
+
+ setBackend b c = c { dcfg_backend = b }
+ mungeDump f c = c { dcfg_dumps = f $ dcfg_dumps c }
+ setOutput o c = c { dcfg_outFile = if o == "-" then Nothing else Just o }
+
+------------------------------------------------------------------------}}}
+-- Pipeline! {{{
+
+processFile :: (?dcfg :: DynacConfig) => String -> IO ()
+processFile fileName = bracket openOut hClose go
+ where
+ openOut = maybe (return stdout) (flip openFile WriteMode)
+ $ dcfg_outFile ?dcfg
+
+ go out = do
+ rs <- parse
+
+ dump DumpParsed (vcat $ map (text.show) rs)
+
+ let urs = map (\(P.LRule x T.:~ _) -> x) rs
+ frs = map normRule urs
+
+ dump DumpANF (vcat $ map printANF frs)
+
+ aggm <- case buildAggMap frs of
+ Left e -> dynacThrow $ UserProgramError (text e)
+ Right x -> return x
+
+ dump DumpAgg (M.foldlWithKey (\d f a -> d `above`
+ (pretty f <+> colon <+> pretty a))
+ empty aggm)
+
+ case dcfg_backend ?dcfg of
+ Backend be_b be_c be_d ->
+ let initializers = MA.mapMaybe
+ (\(f,mca) -> (\(c,a) -> (f,c,a)) `fmap` mca)
+ $ map (\x -> (x, planInitializer be_b x)) frs
+
+
+ cPlans = combinePlans
+ $ map (\x -> (x, planEachEval be_b
+ (not . flip S.member be_c) x))
+ frs
+ in be_d aggm cPlans initializers out
+
+ parse = do
+ pr <- T.parseFromFileEx (P.dlines <* T.eof) fileName
+ case pr of
+ T.Failure td -> dynacUserErr $ align ("Parser error" `above` td)
+ T.Success rs -> return rs
+
+------------------------------------------------------------------------}}}
+-- Main {{{
+
+main_ :: [String] -> IO ()
+main_ argv = do
+ (dcfg, fis) <- procArgs argv
+ let ?dcfg = dcfg
+ case fis of
+ [] -> dynacThrow $ InvocationError "Must specify a Dyna file"
+ [x] -> processFile x
+ _ -> dynacSorry "We can't do more than one file"
+
+main :: IO ()
+main = getArgs >>= main_
+
+------------------------------------------------------------------------}}}
-- | The user program contains an error
UserProgramError (PP.Doc TP.Effect)
+ -- | Something went wrong when trying to understand arguments
+ | InvocationError (PP.Doc TP.Effect)
+
-- | We don't implement a feature yet.
| Sorry (PP.Doc TP.Effect)
------------------------------------------------------------------------}}}
-- Utilities {{{
+dynacUserErr, dynacSorry, dynacPanic :: PP.Doc TP.Effect -> a
+dynacUserErr = throw . UserProgramError
+dynacSorry = throw . Sorry
+dynacPanic = throw . Panic
+
dynacThrow :: DynacException -> a
dynacThrow = throw
-dynacSorry = throw . Sorry
-
------------------------------------------------------------------------}}}
--- /dev/null
+-- Bring together all of our test suites
+
+module Dyna.Main.TestsDriver where
+
+import Test.Framework
+-- import qualified Dyna.Backend.K3.Selftest as DBK3S
+import qualified Dyna.Backend.Python.Selftest as DBPS
+import qualified Dyna.ParserHS.Selftest as DPHS
+import qualified Dyna.XXX.TrifectaTests as DXT
+
+main :: IO ()
+main = defaultMain
+ [DPHS.selftest
+ , DXT.selftest
+
+ -- XXX Until this is meaningful...
+ -- ,DBK3S.selftest
+
+ , DBPS.selftest
+ ]
+++ /dev/null
--- Bring together all of our test suites
-
-module Dyna.Test.Main where
-
-import Test.Framework
-import qualified Dyna.Backend.K3.Selftest as DK3S
-import qualified Dyna.ParserHS.Selftest as DPHS
-import qualified Dyna.XXX.TrifectaTests as DXT
-
-main :: IO ()
-main = defaultMain
- [DPHS.selftest
- -- XXX Until this is meaningful...
- -- ,DK3S.selftest
- , DXT.selftest
- ]
+++ /dev/null
--- Bring together all of our test suites
-
--- XXX temporary, use Dyna.Test.Main as soons as timv has upgrades ghc.
-
-module Dyna.Test.Main2 where
-
-import Test.Framework
-import qualified Dyna.ParserHS.Selftest as DPHS
-import qualified Dyna.XXX.TrifectaTests as DXT
-
-main :: IO ()
-main = defaultMain
- [ DPHS.selftest
- , DXT.selftest
- ]
projects / dyna2 / commitdiff