upstream:
git submodule init
git submodule update external/ekmett-parsers external/ekmett-trifecta
- (cd external/ekmett-parsers; cabal install --user)
- (cd external/ekmett-trifecta; cabal install --user)
+ cabal install --user --enable-tests --only-dependencies \
+ external/ekmett-parsers external/ekmett-trifecta .
+ cabal install --user external/ekmett-parsers external/ekmett-trifecta
deps:
- (cabal install --enable-tests --only-dependencies)
+ cabal install --user --enable-tests --only-dependencies .
-build: deps
+build:
cabal configure --user --enable-tests
cabal build
cabal test
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
+Then fetch, build, and install any dependencies (for the moment, we seem to
+be doing OK with vanilla upstreams!)
make deps
Exposed-Modules: Dyna.Analysis.ANF,
+ Dyna.Analysis.Base,
Dyna.Analysis.Mode,
- Dyna.Backend.K3.AST,
- Dyna.Backend.K3.Automation,
- Dyna.Backend.K3.Render,
+ Dyna.Main.BackendDefn,
+ Dyna.Main.Driver,
+ Dyna.Main.Exception,
Dyna.ParserHS.Parser,
- Dyna.XXX.HList,
- Dyna.XXX.THTuple,
Dyna.XXX.Trifecta
- Build-Depends: base >=4,
+ Build-Depends: ansi-wl-pprint >= 0.6,
+ base >=4,
bytestring >=0.9,
charset >=0.3,
containers >=0.4,
ghc-prim >= 0.3,
+ HUnit >=1.2,
mtl >=2.1,
- parsers >=0.2,
+ parsers >=0.5,
reducers >=3.0,
semigroups >=0.8,
tagged >= 0.4.4,
template-haskell,
- trifecta >=0.90,
+ trifecta >= 1.0,
unification-fd,
unordered-containers>=0.2,
utf8-string >=0.3,
- wl-pprint-extras >=3.0
+ wl-pprint-extras >=3.0,
+ wl-pprint-terminfo >=3.0
Executable drepl
Default-Language: Haskell2010
ghc-options: -Wall
-main-is Dyna.REPL
- Build-Depends: base >=4,
+ Build-Depends: ansi-wl-pprint >= 0.6,
+ base >=4,
bytestring >=0.9,
charset >=0.3,
containers >=0.4,
haskeline >=0.6,
mtl >=2.1,
- parsers >=0.2,
+ parsers >=0.5,
process >=1.1,
reducers >=3.0,
semigroups >=0.8,
tagged >= 0.4.4,
- trifecta >=0.90,
+ trifecta >= 1.0,
unification-fd,
unordered-containers>=0.2,
utf8-string >=0.3,
ghc-options: -Wall
-main-is Dyna.Main.Driver
- Build-Depends: base >=4,
+ Build-Depends: ansi-wl-pprint >= 0.6,
+ base >=4,
bytestring >=0.9,
charset >=0.3,
containers >=0.4,
haskeline >=0.6,
HUnit >=1.2,
mtl >=2.1,
- parsers >=0.2,
+ parsers >=0.5,
process >=1.1,
reducers >=3.0,
semigroups >=0.8,
tagged >= 0.4.4,
- trifecta >=0.90,
+ trifecta >= 1.0,
unification-fd,
unordered-containers>=0.2,
utf8-string >=0.3,
ghc-options: -Wall
-main-is Dyna.Main.TestsDriver
- Build-Depends: base >=4,
+ Build-Depends: ansi-wl-pprint >= 0.6,
+ base >=4,
bytestring >=0.9,
charset >=0.3,
containers >=0.4,
ghc-prim >= 0.3,
HUnit >=1.2,
mtl >=2.1,
- parsers >=0.2,
+ parsers >=0.5,
process >=1.1,
reducers >=3.0,
semigroups >=0.8,
test-framework-hunit >=0.2,
test-framework-th >=0.2,
test-framework-golden >= 1.1,
- trifecta >=0.90,
+ trifecta >= 1.0,
unification-fd,
unordered-containers>=0.2,
utf8-string >=0.3,
wl-pprint-extras >=3.0
- Other-Modules: Dyna.Backend.K3.Examples
-
Main-Is: Dyna/Main/TestsDriver.hs
-Subproject commit 82505d74430677c92aedcd3e71ececf491e859b3
+Subproject commit c707806109119e3f54c3064039a4ee2624f18ff1
-Subproject commit 0725065a6f9a7e6e1732cd3a9f326f410b73f312
+Subproject commit fd1aa5e853dd5e015e5df841507ae532558b13d1
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 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 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
+import qualified Text.PrettyPrint.ANSI.Leijen as PPA
+import qualified Text.Trifecta as T
+import qualified Text.Trifecta.Result as TR
------------------------------------------------------------------------}}}
-- Dumping {{{
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
+ TR.Failure td -> dynacUserANSIErr $ PPA.align ("Parser error" PPA.<$> td)
+ TR.Success rs -> return rs
------------------------------------------------------------------------}}}
-- Main {{{
import qualified Data.Typeable as DT
import qualified System.Console.Terminfo.PrettyPrint as TP
import qualified Text.PrettyPrint.Free as PP
+import qualified Text.PrettyPrint.ANSI.Leijen as PPA
------------------------------------------------------------------------}}}
-- Dyna Compiler Exceptions {{{
-- | The user program contains an error
UserProgramError (PP.Doc TP.Effect)
+ -- | Same as 'UserProgramError' but with ANSI documentation
+ | UserProgramANSIError PPA.Doc
+
-- | Something went wrong when trying to understand arguments
| InvocationError (PP.Doc TP.Effect)
dynacSorry = throw . Sorry
dynacPanic = throw . Panic
+dynacUserANSIErr :: PPA.Doc -> a
+dynacUserANSIErr = throw . UserProgramANSIError
+
dynacThrow :: DynacException -> a
dynacThrow = throw
import Data.Semigroup ((<>))
import Data.Monoid (mempty)
import Text.Parser.Expression
+import Text.Parser.LookAhead
import Text.Parser.Token.Highlight
import Text.Parser.Token.Style
import Text.Trifecta
}
newtype DynaLanguage m a = DL { unDL :: m a }
- deriving (Functor,Applicative,Alternative,Monad,MonadPlus,Parsing,CharParsing)
+ deriving (Functor,Applicative,Alternative,Monad,MonadPlus,
+ Parsing,CharParsing,LookAheadParsing)
instance MonadTrans DynaLanguage where
lift = DL
nullaryStar = spanned $ flip TFunctor [] <$> (bsf $ string "*")
<* (notFollowedBy $ char '(')
-term :: DeltaParsing m => m (Spanned Term)
+term :: (DeltaParsing m, LookAheadParsing m)
+ => m (Spanned Term)
term = token $ choice
[ parens tfexpr
, spanned $ TVar <$> (bsf $ ident dynaVarStyle)
-- | Sometimes we require that a character not be followed by whitespace
-- and satisfy some additional predicate before we pass it off to some other parser.
-thenAny :: (TokenParsing m, Monad m) => m a -> m Char
+thenAny :: (Monad m, TokenParsing m, LookAheadParsing m)
+ => m a -> m Char
thenAny p = anyChar -- some character
<* lookAhead (notFollowedBy someSpace) -- not followed by space
<* lookAhead p -- and not follwed by the request
-- by itself as being counted as an operator; the dot operator is required
-- to have not-a-space following (to avoid confusion with the end-of-rule
-- marker, which is taken to be "dot space" or "dot eof").
-dotOper :: (Monad m, TokenParsing m) => m [Char]
+dotOper :: (Monad m, TokenParsing m, LookAheadParsing m)
+ => m [Char]
dotOper = try (lookAhead (thenAny anyChar) *> identNL dynaDotOperStyle)
-- | A "comma operator" is a comma necessarily followed by something that
-- would continue to be an operator (i.e. punctuation).
-commaOper :: (Monad m, TokenParsing m) => m [Char]
+commaOper :: (Monad m, TokenParsing m, LookAheadParsing m)
+ => m [Char]
commaOper = try ( lookAhead (thenAny $ _styleLetter dynaCommaOperStyle)
*> identNL dynaCommaOperStyle)
--
-- XXX timv suggests that this should be assocnone for binops as a quick
-- fix. Eventually we should still do this properly.
-termETable :: DeltaParsing m => [[Operator m (Spanned Term)]]
+termETable :: (DeltaParsing m, LookAheadParsing m)
+ => [[Operator m (Spanned Term)]]
termETable = [ [ Prefix $ uf (spanned $ bsf $ symbol "new") ]
, [ Prefix $ uf (spanned $ bsf $ ident dynaPfxOperStyle) ]
, [ Infix (bf (spanned $ bsf $ ident dynaOperStyle)) AssocLeft ]
, [ Infix (bf (spanned $ bsf $ commaOper)) AssocRight ]
]
-tlexpr :: DeltaParsing m => m (Spanned Term)
+tlexpr :: (DeltaParsing m, LookAheadParsing m)
+ => m (Spanned Term)
tlexpr = buildExpressionParser termETable term <?> "Limited Expression"
fullETable :: DeltaParsing m => [[Operator m (Spanned Term)]]
, [ Infix (bf (spanned $ bsf $ symbol "whenever")) AssocNone ]
]
-tfexpr :: DeltaParsing m => m (Spanned Term)
+tfexpr :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Term)
tfexpr = buildExpressionParser fullETable tlexpr <?> "Expression"
-dterm :: DeltaParsing m => m (Spanned Term)
+dterm :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Term)
dterm = unDL term
------------------------------------------------------------------------}}}
-- Rules {{{
-parseRule :: (MonadState RuleIx m, DeltaParsing m) => m Rule
+parseRule :: (MonadState RuleIx m, DeltaParsing m, LookAheadParsing m)
+ => m Rule
parseRule = choice [
-- HEAD AGGR TFEXPR .
try $ rule <*> term
]
<* optional (char '.')
-drule :: (DeltaParsing m) => m (Spanned Rule)
+drule :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Rule)
drule = evalStateT (unDL (spanned parseRule)) 0
------------------------------------------------------------------------}}}
-- Lines {{{
-dpragma :: DeltaParsing m => m (Spanned Term)
+dpragma :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Term)
dpragma = symbol ":-"
*> whiteSpace
*> tlexpr
<* whiteSpace
<* optional (char '.')
-progline :: (MonadState RuleIx m, DeltaParsing m) => m (Spanned Line)
+progline :: (MonadState RuleIx m, DeltaParsing m, LookAheadParsing m)
+ => m (Spanned Line)
progline = whiteSpace
*> spanned (choice [ LRule <$> spanned parseRule
, LPragma <$> dpragma
])
-dline :: (DeltaParsing m) => m (Spanned Line)
+dline :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Line)
dline = evalStateT (unDL (progline <* optional whiteSpace)) 0
--- XXX This is not prepared for parser-altering pragmas. We will have to
--- fix that.
-dlines :: DeltaParsing m => m [Spanned Line]
+-- XXX This is not prepared for parser-altering pragmas.
+dlines :: (DeltaParsing m, LookAheadParsing m) => m [Spanned Line]
dlines = evalStateT (unDL (many (progline <* optional whiteSpace))) 0
------------------------------------------------------------------------}}}
case_failIncompleteExpr :: Assertion
case_failIncompleteExpr = checkParseFail dterm "foo +"
- "(interactive):1:5: error: expected: \"(\",\n end of input\nfoo +<EOF> "
+ "(interactive):1:5: error: expected: \"(\",\nend of input\nfoo +<EOF> \n ^ "
------------------------------------------------------------------------}}}
-- Annotations {{{
sr = "goal += 1."
-- XXX for some reason parser is fine with "1." but not "0."
--- This is almost surely a bug upstream
+-- This is almost surely a bug upstream; it's fixed in parsers
+-- c707806109119e3f54c3064039a4ee2624f18ff1, but that isn't yet cut into a
+-- release.
+--
-- case_ruleSimple0 :: Assertion
-- case_ruleSimple0 = e @=? (progline sr)
-- where
-- e = LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr)
-- "+="
--- []
-- (_tNumeric (Left 0) :~ Span (Columns 8 8) (Columns 9 9) sr)
-- :~ ts)
-- :~ ts
import Control.Applicative ((<*))
import Control.Monad.Trans (liftIO)
import System.Console.Haskeline
-import Text.PrettyPrint.Free
-import Text.Trifecta
+import System.IO
+import System.Process
+import qualified Text.PrettyPrint.ANSI.Leijen as PPA
+import Text.Trifecta as T
+import Text.Trifecta.Result as TR
-import qualified Dyna.ParserHS.Parser as DP
--- import qualified Dyna.NormalizeParse as DNP
+import qualified Dyna.ParserHS.Parser as DP
+-- import qualified Dyna.NormalizeParse as DNP
import Dyna.XXX.Trifecta
main :: IO ()
loop
failure td = do
- liftIO $ displayLn td
+ liftIO $ PPA.hPutDoc stdout td
loop
import Control.Applicative
import Control.Monad (when)
import qualified Data.ByteString.UTF8 as BU
-import Data.Char
-import Data.List (foldl')
import Data.Monoid (mempty)
import Data.HashSet as HashSet (member)
import qualified Data.Semigroup.Reducer as R
+import qualified Data.Int as I
import Text.Parser.Token.Highlight
import Text.Trifecta
import Text.Trifecta.Delta
-
+import Text.Trifecta.Result
import qualified Text.PrettyPrint.Free as PP
+import qualified Text.PrettyPrint.ANSI.Leijen as PPA
-- import Debug.Trace
stringLiteralSQ :: TokenParsing m => m String
stringLiteralSQ = token (highlight StringLiteral lit) where
lit = Prelude.foldr (maybe id (:)) ""
- <$> between (char '\'') (char '\'' <?> "end of string") (many stringChar)
+ <$> between (char '\'') (char '\'' <?> "end of string") (many $ Just <$> characterChar)
<?> "string"
- stringChar = Just <$> stringLetter
- <|> stringEscape
- <?> "string character"
- stringLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))
- -- XXX That is, charLetter
-
- stringEscape = highlight EscapeCode $ char '\\' *> esc where
- esc = Nothing <$ escapeGap
- <|> Nothing <$ escapeEmpty
- <|> Just <$> escapeCode
- escapeEmpty = char '&'
- escapeGap = skipSome space *> (char '\\' <?> "end of string gap")
{-# INLINE stringLiteralSQ #-}
--- XXX Duplicated from Text.Parser.Token
-escapeCode :: TokenParsing m => m Char
-escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) <?> "escape code"
- where
- charControl = (\c -> toEnum (fromEnum c - fromEnum 'A')) <$> (char '^' *> upper)
- charNum = toEnum . fromInteger <$> num where
- num = decimal
- <|> (char 'o' *> number 8 octDigit)
- <|> (char 'x' *> number 16 hexDigit)
- charEsc = choice $ parseEsc <$> escMap
- parseEsc (c,code) = code <$ char c
- escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")
- charAscii = choice $ parseAscii <$> asciiMap
- parseAscii (asc,code) = try $ code <$ string asc
- asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
- ascii2codes, ascii3codes :: [String]
- ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO"
- , "SI","EM","FS","GS","RS","US","SP"]
- ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK"
- ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK"
- ,"SYN","ETB","CAN","SUB","ESC","DEL"]
- ascii2, ascii3 :: [Char]
- ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI'
- ,'\EM','\FS','\GS','\RS','\US','\SP']
- ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK'
- ,'\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK'
- ,'\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']
-
--- XXX Duplicated from Text.Parser.Token
-number :: TokenParsing m => Integer -> m Char -> m Integer
-number base baseDigit =
- foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 <$> some baseDigit
-
------------------------------------------------------------------------}}}
-- pureSpanned {{{
=> (Parser a) -- ^ Parser
-> (m (Maybe String)) -- ^ Continuation callback
-> (a -> m b) -- ^ Success callback
- -> (TermDoc -> m b) -- ^ Failure callback
+ -> (PPA.Doc -> m b) -- ^ Failure callback
-> String -- ^ Initial input
-> m b
triInteract p c s f i = loop (feed (BU.fromString i) $ stepParser (release dd *> p) dd mempty)
-- 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
+prettySpanLoc (Span s e _) = doPretty s PP.<> PP.char '-' PP.<> doPretty e
+ where
+ -- This is pretty from the Pretty Delta instance of Text.Trifecta.Delta
+ -- stripped of its ANSI commands so that it works with
+ -- Text.PrettyPrint.Free. Le sigh! XXX
+ doPretty d = case d of
+ Columns c _ -> k f 0 c
+ Tab x y _ -> k f 0 (nextTab x + y)
+ Lines l c _ _ -> k f l c
+ Directed fn l c _ _ -> k fn l c
+ where
+ k :: BU.ByteString -> I.Int64 -> I.Int64 -> PP.Doc e
+ k fn ln cn = PP.pretty fn
+ PP.<> PP.char ':'
+ PP.<> PP.pretty (ln+1)
+ PP.<> PP.char ':'
+ PP.<> PP.pretty (cn+1)
+ f :: BU.ByteString
+ f = "(interactive)"
------------------------------------------------------------------------}}}
import Data.Monoid (mempty)
import Test.HUnit
import Text.Trifecta
+import Text.Trifecta.Result
+import qualified Text.PrettyPrint.ANSI.Leijen as PPA
unsafeFS :: Result t -> t
unsafeFS (Success a) = a
unsafeFF :: String -> Result t -> Assertion
unsafeFF _ (Success _) = error $ "Unexpected success"
-unsafeFF e (Failure td) = e @=? show td
+unsafeFF e (Failure td) = e @=? flip PPA.displayS ""
+ (filterSD $ PPA.renderCompact td)
+ where
+ -- strip out any ANSI BS
+ filterSD PPA.SEmpty = PPA.SEmpty
+ filterSD (PPA.SChar c x) = PPA.SChar c (filterSD x)
+ filterSD (PPA.SText i s x) = PPA.SText i s (filterSD x)
+ filterSD (PPA.SLine i x) = PPA.SLine i (filterSD x)
+ filterSD (PPA.SSGR _ x) = filterSD x
unsafeParse :: (Show a) => (Parser a) -> ByteString -> a
unsafeParse p = unsafeFS . parseByteString (p <* eof) mempty
projects / dyna2 / commitdiff