From f08a37f7e5c13ec04f0e363da838ff830ff7cafc Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Sun, 31 Mar 2013 03:12:53 -0400 Subject: [PATCH] First pass at disposition pragmas --- dyna.cabal | 59 +++--- src/Dyna/Analysis/ANF.hs | 63 ++----- src/Dyna/Main/Driver.hs | 2 +- src/Dyna/ParserHS/Parser.hs | 325 +++++++++++++++++++++------------ src/Dyna/ParserHS/Selftest.hs | 23 ++- src/Dyna/Term/SurfaceSyntax.hs | 75 ++++++++ src/Dyna/XXX/MonadUtils.hs | 4 +- src/Dyna/XXX/Trifecta.hs | 10 +- 8 files changed, 357 insertions(+), 204 deletions(-) create mode 100644 src/Dyna/Term/SurfaceSyntax.hs diff --git a/dyna.cabal b/dyna.cabal index c466502..ed8f9ad 100644 --- a/dyna.cabal +++ b/dyna.cabal @@ -45,6 +45,7 @@ Library HUnit >=1.2, mtl >=2.1, lens >=3.8, + -- logict >=0.6, parsers >=0.5, recursion-schemes >=3.0, reducers >=3.0, @@ -58,34 +59,34 @@ Library wl-pprint-extras >=3.0, wl-pprint-terminfo >=3.0 -Executable drepl - Default-Language: Haskell2010 - Hs-Source-Dirs: src - - ghc-options: -Wall - -main-is Dyna.REPL - - Build-Depends: ansi-wl-pprint >= 0.6, - base >=4, - bytestring >=0.9, - charset >=0.3, - containers >=0.4, - haskeline >=0.6, - mtl >=2.1, - lens >=3.8, - parsers >=0.5, - process >=1.1, - recursion-schemes >=3.0, - reducers >=3.0, - semigroups >=0.8, - tagged >= 0.4.4, - transformers >= 0.3, - trifecta >= 1.0, - unordered-containers>=0.2, - utf8-string >=0.3, - wl-pprint-extras >=3.0 - - Main-Is: Dyna/REPL.hs +-- Executable drepl +-- Default-Language: Haskell2010 +-- Hs-Source-Dirs: src +-- +-- ghc-options: -Wall +-- -main-is Dyna.REPL +-- +-- Build-Depends: ansi-wl-pprint >= 0.6, +-- base >=4, +-- bytestring >=0.9, +-- charset >=0.3, +-- containers >=0.4, +-- haskeline >=0.6, +-- mtl >=2.1, +-- lens >=3.8, +-- parsers >=0.5, +-- process >=1.1, +-- recursion-schemes >=3.0, +-- reducers >=3.0, +-- semigroups >=0.8, +-- tagged >= 0.4.4, +-- transformers >= 0.3, +-- trifecta >= 1.0, +-- unordered-containers>=0.2, +-- utf8-string >=0.3, +-- wl-pprint-extras >=3.0 +-- +-- Main-Is: Dyna/REPL.hs Executable dyna @@ -104,6 +105,7 @@ Executable dyna HUnit >=1.2, mtl >=2.1, lens >=3.8, + -- logict >=0.6, parsers >=0.5, process >=1.1, recursion-schemes >=3.0, @@ -135,6 +137,7 @@ Test-suite dyna-selftests HUnit >=1.2, mtl >=2.1, lens >=3.8, + -- logict >=0.6, parsers >=0.5, process >=1.1, QuickCheck >= 2.5, diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 9012a0c..30b1e8f 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -89,6 +89,7 @@ import qualified Data.Map as M import qualified Dyna.ParserHS.Parser as P import Dyna.Analysis.Base import Dyna.Term.TTerm +import Dyna.Term.SurfaceSyntax import Dyna.XXX.DataUtils (mapInOrApp) import Dyna.XXX.PPrint (valign) -- import Dyna.Test.Trifecta -- XXX @@ -101,19 +102,13 @@ import Dyna.XXX.Trifecta (prettySpanLoc) ------------------------------------------------------------------------}}} -- Preliminaries {{{ -data SelfDispos = SDInherit - | SDEval - | SDQuote - -data ArgDispos = ADEval - | ADQuote - data ECSrc = ECFunctor | ECExplicit type EvalCtx = (ECSrc,ArgDispos) -data ANFDict = AD +newtype ANFDict = AD { ad_dt :: DisposTab } +{- { -- | A map from (functor,arity) to a list of bits indicating whether to -- (True) or not to (False) evaluate that positional argument. -- @@ -126,6 +121,7 @@ data ANFDict = AD -- | A map from (functor,arity) to self disposition. , ad_self_dispos :: (DFunct,Int) -> SelfDispos } +-} mergeDispositions :: SelfDispos -> (ECSrc, ArgDispos) -> ArgDispos mergeDispositions = md @@ -191,43 +187,6 @@ doUnif v w = if v == w newWarn :: (MonadState ANFState m) => B.ByteString -> [T.Span] -> m () newWarn msg loc = modify (\s -> s { as_warns = (msg,loc):(as_warns s) }) -------------------------------------------------------------------------}}} --- Disposition computations {{{ - --- XXX These should be read from declarations -dynaFunctorArgDispositions :: (DFunct, Int) -> [ArgDispos] -dynaFunctorArgDispositions x = case x of - -- evaluate arithmetic / math - ("exp", 1) -> [ADEval] - ("log", 1) -> [ADEval] - ("mod", 2) -> [ADEval, ADEval] - ("abs", 1) -> [ADEval] - -- logic - ("and", 2) -> [ADEval, ADEval] - ("or", 2) -> [ADEval, ADEval] - ("not", 1) -> [ADEval] - ("=",2) -> [ADQuote,ADQuote] - (name, arity) -> - -- If it starts with a nonalpha, it prefers to evaluate arguments - let d = if C.isAlphaNum $ head $ BU.toString name - then ADQuote - else ADEval - in take arity $ repeat $ d - --- XXX These should be read from declarations -dynaFunctorSelfDispositions :: (DFunct,Int) -> SelfDispos -dynaFunctorSelfDispositions x = case x of - ("pair",2) -> SDQuote - ("eval",1) -> SDEval - ("true",0) -> SDQuote - ("false",0) -> SDQuote - (name, _) -> - -- If it starts with a nonalpha, it prefers to evaluate - let d = if C.isAlphaNum $ head $ BU.toString name - then SDInherit - else SDEval - in d - ------------------------------------------------------------------------}}} -- Normalize a Term {{{ @@ -338,7 +297,7 @@ normTerm_ c@(_,ADEval) ss (P.TFunctor "whenever" [sr, si]) = -- their handling. normTerm_ c ss (P.TFunctor f as) = do - argdispos <- asks $ flip ($) (f,length as) . ad_arg_dispos + argdispos <- asks $ flip fArgEvalDispos (f,length as) . ad_dt normas <- mapM (\(a T.:~ s,d) -> normTerm_ (ECFunctor,d) (s:ss) a) (zip as argdispos) @@ -359,7 +318,7 @@ normTerm_ c ss (P.TFunctor f as) = do return (vs,v':r) in (reverse . snd) `fmap` foldM delin ([],[]) normas - selfdispos <- asks $ flip ($) (f,length as) . ad_self_dispos + selfdispos <- asks $ flip fSelfEvalDispos (f,length as) . ad_dt let dispos = mergeDispositions selfdispos c @@ -388,10 +347,9 @@ data Rule = Rule { r_index :: Int } deriving (Show) --- XXX normRule :: T.Spanned P.Rule -- ^ Term to digest -> Rule -normRule (P.Rule i h a r T.:~ sp) = uncurry ($) $ runNormalize $ do +normRule (P.Rule i h a r dt T.:~ sp) = uncurry ($) $ runNormalize dt $ do nh <- normTerm False h >>= newAssign "_h" . Left nr <- normTerm True r >>= newAssign "_r" . Left return $ Rule i nh a nr sp @@ -402,10 +360,11 @@ normRule (P.Rule i h a r T.:~ sp) = uncurry ($) $ runNormalize $ do -- | Run the normalization routine. -- -- Use as @runNormalize nRule@ -runNormalize :: ReaderT ANFDict (State ANFState) a -> (a, ANFState) -runNormalize = +runNormalize :: DisposTab + -> ReaderT ANFDict (State ANFState) a -> (a, ANFState) +runNormalize dt = flip runState (AS 0 M.empty M.empty [] M.empty []) . - flip runReaderT (AD dynaFunctorArgDispositions dynaFunctorSelfDispositions) + flip runReaderT (AD dt) ------------------------------------------------------------------------}}} -- Pretty Printer {{{ diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index 1e0c0ca..d2eb788 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -252,7 +252,7 @@ processFile fileName = bracket openOut hClose go in be_d aggm cPlans qPlans initializers out parse = do - pr <- T.parseFromFileEx (P.dlines <* T.eof) fileName + pr <- T.parseFromFileEx (P.rawDLines <* T.eof) fileName case pr of TR.Failure td -> dynacUserANSIErr $ PPA.align ("Parser error" PPA.<$> td) TR.Success rs -> return rs diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index ae0051e..99d72b7 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -20,12 +20,16 @@ -- this depends on an upstream fix in Text.Parser.Expression. -- But: I am not worried about it since we don't handle gensyms -- anywhere else in the pipeline yet) +-- +-- Note that, due to @TemplateHaskell@ that this file is not necessarily in +-- the most human-readable order. -- Header material {{{ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} @@ -34,12 +38,15 @@ {-# LANGUAGE UndecidableInstances #-} module Dyna.ParserHS.Parser ( - Term(..), dterm, - Rule(..), drule, Line(..), dline, dlines + PCS, defPCS, + Term(..), rawDTerm, + Rule(..), rawDRule, Line(..), rawDLine, rawDLines ) where import Control.Applicative +import Control.Lens import Control.Monad +import Control.Monad.Reader import Control.Monad.State import qualified Data.ByteString.UTF8 as BU import qualified Data.ByteString as B @@ -56,8 +63,9 @@ import Text.Parser.Token.Style import Text.Trifecta import Dyna.Term.TTerm (Annotation(..), TBase(..)) +import Dyna.Term.SurfaceSyntax import Dyna.XXX.MonadUtils (incState) -import Dyna.XXX.Trifecta (identNL,stringLiteralSQ) +import Dyna.XXX.Trifecta (identNL,stringLiteralSQ,unSpan) ------------------------------------------------------------------------}}} -- Parsed output definition {{{ @@ -77,29 +85,87 @@ type RuleIx = Int -- concern -- just use the parenthesized texpr case) so that there is no -- risk of parsing ambiguity. data Rule = Rule !RuleIx !(Spanned Term) !B.ByteString !(Spanned Term) + !DisposTab deriving (Eq,Show) --- | Smart constructor for building a rule with index -rule :: (Functor f, MonadState RuleIx f) - => f ( Spanned Term - -> B.ByteString - -> Spanned Term - -> Rule) -rule = Rule <$> incState +-- | Pragmas that are recognized by the parser +data Pragma = PDispos !SelfDispos !B.ByteString ![ArgDispos] + | PMisc !Term + deriving (Eq,Show) --- XXX Having one kind of Pragma is probably wrong data Line = LRule (Spanned Rule) - | LPragma !(Spanned Term) + | LPragma Pragma deriving (Eq,Show) +------------------------------------------------------------------------}}} +-- Comment handling {{{ + +dynaCommentStyle :: CommentStyle +dynaCommentStyle = CommentStyle + { _commentStart = "{%" -- XXX? + , _commentEnd = "%}" -- XXX? + , _commentLine = "%" + , _commentNesting = True + } + +newtype DynaLanguage m a = DL { unDL :: m a } + deriving (Functor,Applicative,Alternative,Monad,MonadPlus, + Parsing,CharParsing,LookAheadParsing) + +instance MonadTrans DynaLanguage where + lift = DL + +instance (TokenParsing m, MonadPlus m) => TokenParsing (DynaLanguage m) where + someSpace = buildSomeSpaceParser (lift someSpace) dynaCommentStyle + semi = lift semi + highlight h (DL m) = DL (highlight h m) + +instance DeltaParsing m => DeltaParsing (DynaLanguage m) where + line = lift line + position = lift position + slicedWith f (DL m) = DL $ slicedWith f m + rend = lift rend + restOfLine = lift restOfLine + +instance MonadState s m => MonadState s (DynaLanguage m) where + get = lift get + put = lift . put + state = lift . state + +instance MonadReader r m => MonadReader r (DynaLanguage m) where + ask = lift ask + local f m = DL $ local f (unDL m) + ------------------------------------------------------------------------}}} -- Parser Configuration State {{{ -{- --- | Configuration data threaded deeply into the parser -data PC m = PC { pc_opertab :: OperatorTable m (Spanned Term) } -type PCM m a = StateT (PC m) m a --} +-- | Existentialized operator table; this is a bit of a hack, but it will +-- do just fine for now, I hope. +-- +-- XXX +newtype EOT = EOT { unEOT :: forall m . + (DeltaParsing m, LookAheadParsing m) + => OperatorTable m (Spanned Term) + } + +-- | Configuration state threaded into the parser +-- +-- Note that this type is hidden with the exception of some accessors below. +data PCS = + PCS { _pcs_opertab :: EOT + , _pcs_dispostab :: DisposTab + , _pcs_ruleix :: Int + } +$(makeLenses ''PCS) + +newtype PCM im a = PCM { unPCM :: StateT PCS im a } + deriving (Alternative,Applicative,CharParsing,DeltaParsing, + Functor,LookAheadParsing,Monad,MonadPlus,Parsing,TokenParsing) + +instance (Monad im) => MonadState PCS (PCM im) where + get = PCM get + put = PCM . put + state = PCM . state ------------------------------------------------------------------------}}} -- Utilities {{{ @@ -107,6 +173,39 @@ type PCM m a = StateT (PC m) m a bsf :: Functor f => f String -> f B.ByteString bsf = fmap BU.fromString +-- | Smart constructor for building a rule with index +rule :: (Functor f, MonadState PCS f) + => f ( Spanned Term + -> B.ByteString + -> Spanned Term + -> DisposTab + -> Rule) +rule = Rule <$> (pcs_ruleix <<%= (+1)) + +rs x = get >>= runReaderT x + +defPCS = PCS { _pcs_dispostab = defDisposTab + , _pcs_ruleix = 0 + , _pcs_opertab = EOT $ + -- | The basic expression table for limited expressions. + -- + -- Notably, this excludes @,@ (which is important + -- syntactically) and @whenever@ and @is@ (which are + -- nonsensical in local context) + -- XXX right now all binops are at equal precedence and + -- left-associative; that's wrong. + -- + -- XXX timv suggests that this should be assocnone for + -- binops as a quick fix. Eventually we should still do + -- this properly. + [ [ Prefix $ uf (spanned $ bsf $ symbol "new") ] + , [ Prefix $ uf (spanned $ bsf $ ident dynaPfxOperStyle) ] + , [ Infix (bf (spanned $ bsf $ ident dynaOperStyle)) AssocLeft ] + , [ Infix (bf (spanned $ bsf $ dotOper)) AssocRight ] + , [ Infix (bf (spanned $ bsf $ commaOper)) AssocRight ] + ] + } + ------------------------------------------------------------------------}}} -- Identifier Syles {{{ @@ -183,6 +282,10 @@ dynaAggStyle = IdentifierStyle , _styleReservedHighlight = ReservedOperator } +-- | Aggregators must end with one of these symbols; used to prevent +-- an over-zealous interpretation of concatenation as a rule. +aggTermSyms :: H.HashSet Char +aggTermSyms = H.fromList "=-" dynaAtomStyle :: TokenParsing m => IdentifierStyle m dynaAtomStyle = IdentifierStyle @@ -205,41 +308,6 @@ dynaVarStyle = IdentifierStyle } -------------------------------------------------------------------------}}} --- Comment handling {{{ - -dynaCommentStyle :: CommentStyle -dynaCommentStyle = CommentStyle - { _commentStart = "{%" -- XXX? - , _commentEnd = "%}" -- XXX? - , _commentLine = "%" - , _commentNesting = True - } - -newtype DynaLanguage m a = DL { unDL :: m a } - deriving (Functor,Applicative,Alternative,Monad,MonadPlus, - Parsing,CharParsing,LookAheadParsing) - -instance MonadTrans DynaLanguage where - lift = DL - -instance (TokenParsing m, MonadPlus m) => TokenParsing (DynaLanguage m) where - someSpace = buildSomeSpaceParser (lift someSpace) dynaCommentStyle - semi = lift semi - highlight h (DL m) = DL (highlight h m) - -instance DeltaParsing m => DeltaParsing (DynaLanguage m) where - line = lift line - position = lift position - slicedWith f (DL m) = DL $ slicedWith f m - rend = lift rend - restOfLine = lift restOfLine - -instance MonadState s m => MonadState s (DynaLanguage m) where - get = lift get - put = lift . put - state = lift . state - ------------------------------------------------------------------------}}} -- Atoms {{{ @@ -247,6 +315,8 @@ atom :: (Monad m, TokenParsing m) => m B.ByteString atom = liftA BU.fromString stringLiteralSQ <|> (bsf $ ident dynaAtomStyle) +functor = highlight Identifier atom "Functor" + ------------------------------------------------------------------------}}} -- Terms and term expressions {{{ @@ -254,27 +324,23 @@ nullaryStar :: DeltaParsing m => m (Spanned Term) nullaryStar = spanned $ flip TFunctor [] <$> (bsf $ string "*") <* (notFollowedBy $ char '(') -term :: (DeltaParsing m, LookAheadParsing m) - => m (Spanned Term) -term = token $ choice - [ parens tfexpr - , spanned $ TVar <$> (bsf $ ident dynaVarStyle) +term = token $ choice + [ parens tfexpr + , spanned $ TVar <$> (bsf $ ident dynaVarStyle) - , spanned $ mkta <$> (colon *> term) <* whiteSpace <*> term + , spanned $ mkta <$> (colon *> term) <* whiteSpace <*> term - , try $ spanned $ TBase . TString <$> bsf stringLiteral + , try $ spanned $ TBase . TString <$> bsf stringLiteral - , try $ spanned $ TBase . TNumeric <$> naturalOrDouble + , try $ spanned $ TBase . TNumeric <$> naturalOrDouble - , try $ spanned $ flip TFunctor [] <$> atom - <* (notFollowedBy $ char '(') + , try $ spanned $ flip TFunctor [] <$> atom + <* (notFollowedBy $ char '(') - , try $ nullaryStar - , spanned $ parenfunc - ] + , try $ nullaryStar + , spanned $ parenfunc + ] where - functor = highlight Identifier atom "Functor" - parenfunc = TFunctor <$> functor <*> parens (tlexpr `sepBy` symbolic ',') @@ -318,86 +384,115 @@ bf f = do (x:~spx) <- f pure (\a@(_:~spa) b@(_:~spb) -> (TFunctor x [a,b]):~(spa <> spx <> spb)) --- | The basic expression table --- --- XXX right now all binops are at equal precedence and left-associative; --- that's wrong. --- --- XXX timv suggests that this should be assocnone for binops as a quick --- fix. Eventually we should still do this properly. -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 $ dotOper)) AssocRight ] - , [ Infix (bf (spanned $ bsf $ commaOper)) AssocRight ] - ] -tlexpr :: (DeltaParsing m, LookAheadParsing m) +tlexpr :: (DeltaParsing m, LookAheadParsing m, MonadReader PCS m) => m (Spanned Term) -tlexpr = buildExpressionParser termETable term "Limited Expression" +tlexpr = view pcs_opertab >>= flip buildExpressionParser term . unEOT -fullETable :: DeltaParsing m => [[Operator m (Spanned Term)]] -fullETable = [ [ Infix (bf (spanned $ bsf $ symbol "is" )) AssocNone ] +moreETable :: DeltaParsing m => [[Operator m (Spanned Term)]] +moreETable = [ [ Infix (bf (spanned $ bsf $ symbol "is" )) AssocNone ] , [ Infix (bf (spanned $ bsf $ symbol "," )) AssocRight ] , [ Infix (bf (spanned $ bsf $ symbol "whenever")) AssocNone ] ] -tfexpr :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Term) -tfexpr = buildExpressionParser fullETable tlexpr "Expression" +-- | Full Expression +tfexpr :: (DeltaParsing m, LookAheadParsing m, MonadReader PCS m) + => m (Spanned Term) +tfexpr = buildExpressionParser moreETable tlexpr "Expression" -dterm :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Term) -dterm = unDL term +rawDTerm :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Term) +rawDTerm = runReaderT (unDL term) defPCS ------------------------------------------------------------------------}}} -- Rules {{{ -parseRule :: (MonadState RuleIx m, DeltaParsing m, LookAheadParsing m) +parseAggr :: (DeltaParsing m) => m B.ByteString +parseAggr = + (do + a <- ident dynaAggStyle + when (not $ (last a) `H.member` aggTermSyms) $ + unexpected "Improper terminal character in aggregator" + bsf (pure a) + ) "Aggregator" + +parseRule :: (DeltaParsing m, LookAheadParsing m, MonadState PCS m) => m Rule parseRule = choice [ -- HEAD AGGR TFEXPR . - try $ rule <*> term + try $ rule <*> rs term <* whiteSpace - <*> (bsf $ ident dynaAggStyle "Aggregator") - <*> tfexpr + <*> parseAggr + <*> rs tfexpr + <*> use pcs_dispostab -- HEAD . - -- timv: using ':-' as the "default" aggregator for facts is - -- probably incorrect because it conflicts with '&=' and other - -- logical aggregators. , do - h@(_ :~ s) <- term - ix <- incState - return $ Rule ix h ":-" (TFunctor "true" [] :~ s) + h@(_ :~ s) <- rs term + rule <*> pure h + <*> pure "&=" + <*> pure (TFunctor "true" [] :~ s) + <*> use pcs_dispostab ] - <* optional (char '.') + <* {- optional -} (char '.') -drule :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Rule) -drule = evalStateT (unDL (spanned parseRule)) 0 +rawDRule :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Rule) +rawDRule = evalStateT (unPCM $ unDL $ spanned parseRule) defPCS ------------------------------------------------------------------------}}} --- Lines {{{ +-- Pragmas {{{ -dpragma :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Term) +parsePragma = choice + [ symbol "dispos" *> parseDisposition + -- , symbol "oper" *> parseOper + ] + where + parseDisposition = PDispos <$> selfdis + <*> functor + <*> (parens (argdis `sepBy` symbol ",") + <|> pure []) + where + argdis = choice [ symbol "&" *> pure ADQuote + , symbol "*" *> pure ADEval + ] + selfdis = choice [ symbol "&" *> pure SDQuote + , symbol "*" *> pure SDEval + , pure SDInherit + ] + + parseOper = undefined + +dpragma :: (DeltaParsing m, LookAheadParsing m, MonadReader PCS m) + => m Pragma dpragma = symbol ":-" *> whiteSpace - *> tlexpr + *> (parsePragma + <|> fmap PMisc (unSpan <$> tfexpr "Other pragma")) <* whiteSpace - <* optional (char '.') + <* {- optional -} (char '.') + +------------------------------------------------------------------------}}} +-- Lines {{{ -progline :: (MonadState RuleIx m, DeltaParsing m, LookAheadParsing m) +progline :: (MonadState PCS m, DeltaParsing m, LookAheadParsing m) => m (Spanned Line) progline = whiteSpace - *> spanned (choice [ LRule <$> spanned parseRule - , LPragma <$> dpragma + *> spanned (choice [ LPragma <$> rs dpragma + , LRule <$> spanned parseRule ]) -dline :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Line) -dline = evalStateT (unDL (progline <* optional whiteSpace)) 0 +rawDLine :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Line) +rawDLine = evalStateT (unPCM $ unDL $ progline <* optional whiteSpace) defPCS + +interpretProgline = do + ls@(l :~ _) <- progline + case l of + LPragma (PDispos s f as) -> do + pcs_dispostab %= dtMerge (f,length as) (s,as) + interpretProgline + _ -> return ls + +dparse = (unPCM $ unDL $ many (interpretProgline <* optional whiteSpace) <* eof) --- 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 +rawDLines = evalStateT dparse defPCS ------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index ac12fd4..848537c 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -32,6 +32,7 @@ import Text.Trifecta.Delta import Dyna.ParserHS.Parser import Dyna.Term.TTerm (Annotation(..), TBase(..)) +import Dyna.Term.SurfaceSyntax (defDisposTab) import Dyna.XXX.TrifectaTest ------------------------------------------------------------------------}}} @@ -41,7 +42,7 @@ _tNumeric :: Either Integer Double -> Term _tNumeric = TBase . TNumeric term :: ByteString -> Spanned Term -term = unsafeParse dterm +term = unsafeParse (rawDTerm <* eof) case_basicAtom :: Assertion case_basicAtom = e @=? (term "foo") @@ -142,7 +143,7 @@ case_colonFunctor = e @=? (term pvv) -- gs = "gensym(*)" case_failIncompleteExpr :: Assertion -case_failIncompleteExpr = checkParseFail dterm "foo +" +case_failIncompleteExpr = checkParseFail rawDTerm "foo +" "(interactive):1:5: error: expected: \"(\",\nend of input\nfoo + \n ^ " ------------------------------------------------------------------------}}} @@ -163,17 +164,18 @@ case_tyAnnot = e @=? (term fintx) -- Rules and lines {{{ progline :: ByteString -> Spanned Line -progline = unsafeParse (dline <* eof) +progline = unsafeParse (rawDLine <* eof) proglines :: ByteString -> [Spanned Line] -proglines = unsafeParse (dlines <* eof) +proglines = unsafeParse (rawDLines <* eof) case_ruleFact :: Assertion case_ruleFact = e @=? (progline sr) where e = LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 4 4) sr) - ":-" + "&=" (TFunctor "true" [] :~ Span (Columns 0 0) (Columns 4 4) sr) + defDisposTab :~ ts) :~ ts ts = Span (Columns 0 0) (Columns 5 5) sr @@ -185,6 +187,7 @@ case_ruleSimple = e @=? (progline sr) e = LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) "+=" (_tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 9 9) sr) + defDisposTab :~ ts) :~ ts ts = Span (Columns 0 0) (Columns 10 10) sr @@ -217,6 +220,7 @@ case_ruleExpr = e @=? (progline sr) ] :~ Span (Columns 8 8) (Columns 18 18) sr ) + defDisposTab :~ ts) :~ ts ts = Span (Columns 0 0) (Columns 19 19) sr @@ -233,6 +237,7 @@ case_ruleDotExpr = e @=? (progline sr) ] :~ Span (Columns 8 8) (Columns 15 15) sr ) + defDisposTab :~ ts) :~ ts ts = Span (Columns 0 0) (Columns 16 16) sr @@ -250,6 +255,7 @@ case_ruleComma = e @=? (progline sr) ,TVar "X" :~ Span (Columns 23 23) (Columns 24 24) sr] :~ Span (Columns 15 15) (Columns 24 24) sr] :~ Span (Columns 7 7) (Columns 24 24) sr) + defDisposTab :~ ts) :~ ts ts = Span (Columns 0 0) (Columns 25 25) sr @@ -271,6 +277,7 @@ case_ruleKeywordsComma = e @=? (progline sr) :~ Span (Columns 34 34) (Columns 41 41) sr] :~ Span (Columns 21 21) (Columns 41 41) sr] -- End "whenever" :~ Span (Columns 6 6) (Columns 41 41) sr) -- End expression + defDisposTab :~ ts) -- End rule :~ ts ts = Span (Columns 0 0) (Columns 42 42) sr @@ -282,11 +289,13 @@ case_rules = e @=? (proglines sr) e = [ LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) "+=" (_tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 10 10) sr) + defDisposTab :~ s1) :~ s1 , LRule (Rule 1 (TFunctor "laog" [] :~ Span (Columns 12 12) (Columns 17 17) sr) "min=" (_tNumeric (Left 2) :~ Span (Columns 22 22) (Columns 24 24) sr) + defDisposTab :~ s2) :~ s2 ] @@ -300,11 +309,13 @@ case_rulesWhitespace = e @=? (proglines sr) e = [ LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 2 2) (Lines 1 1 16 1) l0) "+=" (_tNumeric (Left 1) :~ Span (Lines 1 4 19 4) (Lines 1 6 21 6) l1) + defDisposTab :~ s1) :~ s1 , LRule (Rule 1 (TFunctor "goal" [] :~ Span (Lines 3 1 31 1) (Lines 3 6 36 6) l3) "+=" (_tNumeric (Left 2) :~ Span (Lines 3 9 39 9) (Lines 3 11 41 11) l3) + defDisposTab :~ s2) :~ s2 ] @@ -328,11 +339,13 @@ case_rulesDotExpr = e @=? (proglines sr) ] :~ Span (Columns 8 8) (Columns 15 15) sr ) + defDisposTab :~ s1) :~ s1 , LRule (Rule 1 (TFunctor "goal" [] :~ Span (Columns 17 17) (Columns 22 22) sr) "+=" (_tNumeric (Left 1) :~ Span (Columns 25 25) (Columns 27 27) sr) + defDisposTab :~ s2) :~ s2 ] diff --git a/src/Dyna/Term/SurfaceSyntax.hs b/src/Dyna/Term/SurfaceSyntax.hs new file mode 100644 index 0000000..271067c --- /dev/null +++ b/src/Dyna/Term/SurfaceSyntax.hs @@ -0,0 +1,75 @@ +--------------------------------------------------------------------------- +-- | Things common to surface syntax representation of terms that are used +-- by several stages of the pipeline. + +-- Header material {{{ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dyna.Term.SurfaceSyntax where + +import qualified Data.ByteString.UTF8 as BU +import qualified Data.Char as C +import qualified Data.Map as M +import Dyna.Term.TTerm + +------------------------------------------------------------------------}}} +-- Evaluation Disposition {{{ +-- Definition {{{ + +data SelfDispos = SDInherit + | SDEval + | SDQuote + deriving (Eq,Show) + +data ArgDispos = ADEval + | ADQuote + deriving (Eq,Show) + +type DisposTab = M.Map (DFunct,Int) (SelfDispos,[ArgDispos]) + +------------------------------------------------------------------------}}} +-- Functions {{{ + +dtMerge = M.insert +{-# INLINE dtMerge #-} + +fSelfEvalDispos :: DisposTab -> (DFunct, Int) -> SelfDispos +fSelfEvalDispos t fa = maybe def fst $ M.lookup fa t + where + def = let (name,_) = fa + in maybe SDEval id $ fmap test $ BU.uncons name + test (x,_) = if C.isAlphaNum x then SDInherit else SDEval + +fArgEvalDispos :: DisposTab -> (DFunct, Int) -> [ArgDispos] +fArgEvalDispos t fa = maybe def snd $ M.lookup fa t + where + def = let (name,arity) = fa + in take arity $ repeat + $ maybe ADEval id $ fmap test $ BU.uncons name + test (x,_) = if C.isAlphaNum x then ADQuote else ADEval + +------------------------------------------------------------------------}}} +-- Defaults {{{ + +defDisposTab :: DisposTab +defDisposTab = M.fromList [ + -- math + (("abs" ,1),(SDEval,[ADEval])) + , (("exp" ,1),(SDEval,[ADEval])) + , (("log" ,1),(SDEval,[ADEval])) + , (("mod" ,2),(SDEval,[ADEval,ADEval])) + -- logic + , (("=" ,2),(SDEval,[ADQuote,ADQuote])) + , (("and" ,2),(SDEval,[ADEval, ADEval])) + , (("or" ,2),(SDEval,[ADEval, ADEval])) + , (("not" ,1),(SDEval,[ADEval])) + -- structure + , (("eval" ,1),(SDEval,[ADEval])) + , (("pair" ,2),(SDQuote,[ADEval,ADEval])) + , (("true" ,0),(SDQuote,[])) + , (("false",0),(SDQuote,[])) + ] + +------------------------------------------------------------------------}}} +------------------------------------------------------------------------}}} diff --git a/src/Dyna/XXX/MonadUtils.hs b/src/Dyna/XXX/MonadUtils.hs index b0faf11..46207c1 100644 --- a/src/Dyna/XXX/MonadUtils.hs +++ b/src/Dyna/XXX/MonadUtils.hs @@ -7,7 +7,7 @@ module Dyna.XXX.MonadUtils( bracketState, incState, ) where -import Control.Applicative +-- import Control.Applicative import Control.Lens import Control.Monad.State import qualified Data.Map as M @@ -51,7 +51,7 @@ bracketState bs m = do r <- m s' <- get put s - return (r, bs) + return (r, s') incState :: (Num a, MonadState a m) => m a incState = id <<%= (+1) diff --git a/src/Dyna/XXX/Trifecta.hs b/src/Dyna/XXX/Trifecta.hs index bacbf2c..30b6dd9 100644 --- a/src/Dyna/XXX/Trifecta.hs +++ b/src/Dyna/XXX/Trifecta.hs @@ -4,7 +4,8 @@ -- Header material {{{ module Dyna.XXX.Trifecta ( - identNL, pureSpanned, stringLiteralSQ, triInteract, prettySpanLoc + identNL, pureSpanned, stringLiteralSQ, triInteract, prettySpanLoc, + unSpan ) where import Control.Applicative @@ -59,6 +60,13 @@ stringLiteralSQ = token (highlight StringLiteral lit) where pureSpanned :: DeltaParsing m => a -> m (Spanned a) pureSpanned r = (liftA (r :~) $ Span <$> position <*> position <*> line) +------------------------------------------------------------------------}}} +-- unSpan {{{ + +unSpan :: Spanned a -> a +unSpan (x :~ _) = x +{-# INLINE unSpan #-} + ------------------------------------------------------------------------}}} -- Interaction {{{ -- 2.50.1