From: Nathaniel Wesley Filardo Date: Wed, 29 May 2013 02:00:35 +0000 (-0400) Subject: Syntax modernization and cleanups X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=66b9d3dacfe823acfdefd3aefff57ea966b32640;p=dyna2 Syntax modernization and cleanups Thanks to Juneki Hong for bringing to my attention that some of the examples no longer built. --- diff --git a/examples/agg-conflict.dyna b/examples/agg-conflict.dyna deleted file mode 100644 index ef65766..0000000 --- a/examples/agg-conflict.dyna +++ /dev/null @@ -1,5 +0,0 @@ - - -% example of conflicting aggregators -a += 3. -a *= 2. \ No newline at end of file diff --git a/examples/matrixops.dyna b/examples/matrixops.dyna index c2050ce..aadab38 100644 --- a/examples/matrixops.dyna +++ b/examples/matrixops.dyna @@ -1,23 +1,20 @@ - - - - % A and B are names of matrices -times(A, B, I, J) += m(A, I, K) * m(B, K, J) whenever product(A,B). % use "?" +times(A, B, I, J) += m(A, I, K) * m(B, K, J) whenever _ is product(A,B). -m(P, I, J) += pair(R, C) is shape(A), - pair(C, D) is shape(B), +m(P, I, J) += shape(A,R,C), % pair(R, C) is shape(A), + shape(B,C,_), % pair(C, D) is shape(B), P is product(A, B), times(A, B, I, J). %shape(P, R, C) :- P is product(A, B), shape(A, R, X), shape(B, X, C). +%shape(A) += &pair(rows(A), cols(A)). -shape(A) += &pair(*rows(A), *cols(A)). - -%shape(X, *rows(X), *cols(X)). +shape(X, rows(X), cols(X)). rows(X) max= m(X, R, _), R. cols(X) max= m(X, _, C), C. +% define some matrices +:-dispos m(&,*,*). % matrix "a" = [ 1 0 ; % 0 1 ] @@ -36,4 +33,5 @@ m(b, 2, 2) += 2. m(b, 2, 3) += 0 . % matrix "c" is the product of matricies "a" and "b" -product(a,b) += &c +:-dispos product(&,&). +product(a,b) += &c . diff --git a/examples/papa2.dyna b/examples/papa2.dyna index 34f383f..d081936 100644 --- a/examples/papa2.dyna +++ b/examples/papa2.dyna @@ -1,12 +1,12 @@ % Parsing a simple sentence. % CKY-like parsing -phrase(X,I,K,t(X,TY)) max= phrase(Y,I,K,TY) * rewrite(X,Y). -phrase(X,I,K,t(X,TY,TZ)) max= phrase(Y,I,J,TY) * phrase(Z,J,K,TZ) * rewrite(X,Y,Z). +phrase(X,I,K, &t(X,TY)) max= phrase(Y,I,K,TY) * rewrite(X,Y). +phrase(X,I,K, &t(X,TY,TZ)) max= phrase(Y,I,J,TY) * phrase(Z,J,K,TZ) * rewrite(X,Y,Z). -goal(P) max= phrase("S", 0, *length, P). +goal(P) max= phrase("S", 0, length, P). -best max= pair(phrase("S", 0, *length, P), P). +best max= pair(phrase("S", 0, length, P), P). bestScore max= Score for pair(Score,_) is best. bestParse max= P for pair(_,P) is best. diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 57c1ff0..d875c81 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -348,7 +348,7 @@ normTerm_ c@(_,ADEval) ss (P.TFunctor f [sr, si]) | f `elem` dynaRevConjOpers = -- their handling. normTerm_ c ss (P.TFunctor f as) = do - argdispos <- asks $ flip fArgEvalDispos (f,length as) . ad_dt + argdispos <- asks $ flip dt_argEvalDispos (f,length as) . ad_dt normas <- mapM (\(a T.:~ s,d) -> normTerm_ (ECFunctor,d) (s:ss) a) (zip as argdispos) @@ -369,7 +369,7 @@ normTerm_ c ss (P.TFunctor f as) = do return (vs,v':r) in (reverse . snd) `fmap` foldM delin ([],[]) normas - selfdispos <- asks $ flip fSelfEvalDispos (f,length as) . ad_dt + selfdispos <- asks $ flip dt_selfEvalDispos (f,length as) . ad_dt let dispos = mergeDispositions selfdispos c diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index ab77526..9ba85a5 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -20,6 +20,7 @@ import qualified Data.ByteString.UTF8 as BU import qualified Data.Map as M import qualified Data.Maybe as MA import qualified Data.Set as S +import Data.String import Dyna.Analysis.Aggregation import Dyna.Analysis.ANF import Dyna.Analysis.ANFPretty @@ -272,7 +273,7 @@ processFile fileName = bracket openOut hClose go $ map (\x -> (x, planInitializer be_b x)) frs - cPlans = combineUpdatePlans + uPlans = combineUpdatePlans $ map (\x -> (x, planEachEval be_b (flip S.member be_c) x)) frs @@ -284,9 +285,16 @@ processFile fileName = bracket openOut hClose go -} in do - dump DumpDopIni (renderDopInis be_ddi initializers) - dump DumpDopUpd (renderDopUpds be_ddi cPlans) - be_d aggm cPlans {- qPlans -} initializers out + -- Force evaluation of a lot of the work of the compiler, + -- even if the backend and dump flags won't do it for us. + initializers' <- evaluate $ initializers + uPlans' <- evaluate $ uPlans + + dump DumpDopIni (renderDopInis be_ddi initializers') + dump DumpDopUpd (renderDopUpds be_ddi uPlans') + + -- Invoke the backend code generator + be_d aggm uPlans' {- qPlans -} initializers' out parse = do pr <- T.parseFromFileEx (P.rawDLines <* T.eof) fileName @@ -307,26 +315,24 @@ main_ argv = do _ -> dynacSorry "We can't do more than one file" main :: IO () -main = handle someExnPanic $ handle printerr (getArgs >>= main_) +main = catches (getArgs >>= main_) + [Handler printerr, Handler someExnPanic] + where printerr x = pe x >> exitFailure pe (UserProgramError d) = do - hPutStrLn stderr "FATAL: Encountered error in input program:" - PP.hPutDoc stderr d + PP.hPutDoc stderr (upeMsg <> line <> PP.indent 1 d) hPutStrLn stderr "" pe (UserProgramANSIError d) = do - hPutStrLn stderr "FATAL: Encountered error in input program:" - PPA.hPutDoc stderr d + PPA.hPutDoc stderr (upeMsg <> PPA.line <> PPA.indent 1 d) hPutStrLn stderr "" pe (InvocationError d) = do - hPutStrLn stderr "Invocation error:" - PP.hPutDoc stderr d + PP.hPutDoc stderr ("Invocation error:" <> line <> PP.indent 1 d) + hPutStrLn stderr "" quickExit QEHelp pe (Sorry d) = do - hPutStrLn stderr "Terribly sorry, but you've hit an unsupported feature" - taMsg - PP.hPutDoc stderr d + PP.hPutDoc stderr (sorryMsg <> line <> taMsg <> line <> PP.indent 1 d) hPutStrLn stderr "" pe (Panic d) = panic d @@ -334,12 +340,18 @@ main = handle someExnPanic $ handle printerr (getArgs >>= main_) <+> text (show e) panic d = do - hPutStrLn stderr "Compiler panic!" - taMsg - PP.hPutDoc stderr d + PP.hPutDoc stderr (panicMsg <> line <> taMsg <> line <> PP.indent 1 d) hPutStrLn stderr "" - taMsg = do - hPutStrLn stderr $ "This is almost assuredly not your fault!" - ++ " Please contact a TA." + upeMsg :: (IsString s) => s + upeMsg = "FATAL: Encountered error in input program:" + + sorryMsg :: (IsString s) => s + sorryMsg = "Terribly sorry, but you've hit an unsupported feature" + + panicMsg :: (IsString s) => s + panicMsg = "Compiler panic!" + + taMsg :: (IsString s) => s + taMsg = "This is almost assuredly not your fault! Please contact a TA." ------------------------------------------------------------------------}}} diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index 8bc4f42..b44faf4 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -5,6 +5,9 @@ -- -- as well as the trifecta code itself -- +-- Note that, due to @TemplateHaskell@ that this file is not necessarily in +-- the most human-readable order. +-- -- TODO (XXX): -- -- * We might want to use T.T.Literate, too, in the end. @@ -23,8 +26,6 @@ -- 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 #-} @@ -42,7 +43,7 @@ module Dyna.ParserHS.Parser ( PCS, defPCS, Term(..), rawDTerm, - Rule(..), rawDRule, Line(..), rawDLine, rawDLines + Rule(..), RuleIx, rawDRule, rawDRules, Line(..), rawDLine, rawDLines ) where import Control.Applicative @@ -52,33 +53,37 @@ import Control.Monad.Reader import Control.Monad.State import qualified Data.ByteString.UTF8 as BU import qualified Data.ByteString as B --- import Data.Char (isSpace) import qualified Data.CharSet as CS import qualified Data.Data as D import qualified Data.HashSet as H import qualified Data.Map as M import Data.Semigroup ((<>)) import Data.Monoid (mempty) +import Dyna.Analysis.Mode.Inst +import Dyna.Analysis.Mode.Uniq +import Dyna.Main.Exception +import Dyna.Term.TTerm (Annotation(..), TBase(..), + DFunct, DFunctAr, DVar) +import Dyna.Term.SurfaceSyntax +import Dyna.XXX.MonadUtils (incState) +import Dyna.XXX.Trifecta (identNL,prettySpanLoc, + stringLiteralSQ,unSpan) import Text.Parser.Expression import Text.Parser.LookAhead import Text.Parser.Token.Highlight import Text.Parser.Token.Style +import qualified Text.PrettyPrint.Free as PP import Text.Trifecta -import Dyna.Term.TTerm (Annotation(..), TBase(..)) -import Dyna.Term.SurfaceSyntax -import Dyna.XXX.MonadUtils (incState) -import Dyna.XXX.Trifecta (identNL,stringLiteralSQ,unSpan) - ------------------------------------------------------------------------}}} -- Parsed output definition {{{ -data Term = TFunctor !B.ByteString - ![Spanned Term] - | TAnnot !(Annotation (Spanned Term)) - !(Spanned Term) - | TVar !B.ByteString - | TBase !TBase +data Term = TFunctor B.ByteString + [Spanned Term] + | TAnnot (Annotation (Spanned Term)) + (Spanned Term) + | TVar B.ByteString + | TBase TBase deriving (D.Data,D.Typeable,Eq,Ord,Show) type RuleIx = Int @@ -87,15 +92,60 @@ type RuleIx = Int -- explicit about the head being a term (though that's not an expressivity -- 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 +-- +-- Each 'Rule' additionally carries its own 'DisposTab' for conversion to +-- ANF. We cannot return just one 'DisposTab' when we are done parsing +-- because each +data Rule = Rule RuleIx (Spanned Term) B.ByteString (Spanned Term) + DisposTab + +instance Show Rule where + showsPrec p (Rule i h a b _) = showParen (p > 9) $ + showString "Rule " . + showsPrec 6 i . + showString " " . + showsPrec 6 h . + showString " " . + showsPrec 6 a . + showString " " . + showsPrec 6 b . + showString " _" + +data NameWithArgs = PNWA B.ByteString [B.ByteString] deriving (Eq,Show) -- | Pragmas that are recognized by the parser -data Pragma = PDispos !SelfDispos !B.ByteString ![ArgDispos] - | POperAdd !PragmaFixity !Integer !B.ByteString - | POperDel !B.ByteString - | PMisc !Term +data Pragma = PDispos SelfDispos B.ByteString [ArgDispos] + -- ^ Assert the evaluation disposition of a functor + + | PDisposDefl String + -- ^ Specify the default disposition handlers + -- for subsequent context. + -- + -- Note that the override defintions are + -- preserved across this operation! + -- (XXX is that what we want?) + + | PInst NameWithArgs -- ^ inst name + ParsedInst -- ^ defn body + -- ^ Declare an instantiation state name + + | PMode NameWithArgs -- ^ mode name + ParsedModeInst -- ^ From + ParsedModeInst -- ^ To + -- ^ Declare a mode name + + | POperAdd PragmaFixity Integer B.ByteString + -- ^ Add an operator + + | POperDel B.ByteString + -- ^ Remove an operator + + | PQMode DFunctAr + -- ^ A query mode declaration + + | PMisc Term + -- ^ Fall-back parser for :- lines. deriving (Eq,Show) data PragmaFixity = PFIn PAssoc | PFPre | PFPost @@ -106,48 +156,16 @@ data PragmaFixity = PFIn PAssoc | PFPre | PFPost data PAssoc = PAssocNone | PAssocLeft | PAssocRight deriving (Eq,Show) -data Line = LRule (Spanned Rule) - | LPragma Pragma +-- | The type of a parsed inst declaration +data ParsedInst = PIVar !B.ByteString + | PIInst !(InstF DFunct ParsedInst) deriving (Eq,Show) -------------------------------------------------------------------------}}} --- Comment handling {{{ +type ParsedModeInst = Either NameWithArgs ParsedInst -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) +data Line = LRule (Spanned Rule) + | LPragma Pragma + deriving (Show) ------------------------------------------------------------------------}}} -- Parser Configuration State {{{ @@ -165,13 +183,29 @@ newtype EOT = EOT { unEOT :: forall m . -- -- Note that this type is hidden with the exception of some accessors below. data PCS = - PCS { _pcs_opertab :: EOT + PCS { _pcs_dt_mk :: DisposTabOver -> DisposTab + , _pcs_dt_over :: DisposTabOver + , _pcs_instmap :: M.Map B.ByteString ([DVar] + ,ParsedInst + ,Span) + -- ^ Collects inst pragmas + -- + -- XXX add arity to key? + , _pcs_modemap :: M.Map B.ByteString ([DVar] + ,ParsedModeInst + ,ParsedModeInst + ,Span) + -- ^ Collects mode pragmas + -- + -- XXX add arity to key? + , _pcs_opertab :: EOT , _pcs_operspec :: M.Map B.ByteString () -- XXX - , _pcs_dispostab :: DisposTab , _pcs_ruleix :: Int } $(makeLenses ''PCS) +pcs_dt = liftA2 ($) (use pcs_dt_mk) (use pcs_dt_over) + newtype PCM im a = PCM { unPCM :: StateT PCS im a } deriving (Alternative,Applicative,CharParsing,DeltaParsing, Functor,LookAheadParsing,Monad,MonadPlus,Parsing,TokenParsing) @@ -187,6 +221,11 @@ instance (Monad im) => MonadState PCS (PCM im) where bsf :: Functor f => f String -> f B.ByteString bsf = fmap BU.fromString +parseNameWithArgs n = PNWA <$> n + <*> choice [ parens ( var `sepBy` comma ) + , pure [] + ] + -- | Smart constructor for building a rule with index rule :: (Functor f, MonadState PCS f) => f ( Spanned Term @@ -196,34 +235,76 @@ rule :: (Functor f, MonadState PCS f) -> Rule) rule = Rule <$> (pcs_ruleix <<%= (+1)) +rs :: (MonadState a m) => ReaderT a m b -> m b rs x = get >>= runReaderT x -defPCS = PCS { _pcs_dispostab = defDisposTab - , _pcs_ruleix = 0 - , _pcs_operspec = M.empty -- XXX - , _pcs_opertab = EOT $ - -- The basic expression table for limited expressions. +defPCS = PCS { _pcs_dt_mk = disposTab_dyna + , _pcs_dt_over = mempty + , _pcs_instmap = mempty -- XXX + , _pcs_modemap = mempty -- XXX + , _pcs_operspec = mempty -- XXX + , _pcs_opertab = EOT $ + -- The basic expression table for limited expressions. + -- + -- Notably, this excludes @,@ (which is important + -- syntactically), @for@, @whenever@, and @is@ (which are + -- nonsensical in local context) + -- XXX right now all binops are at equal precedence and + -- left-associative; that's wrong. -- - -- Notably, this excludes @,@ (which is important - -- syntactically), @for@, @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. -- - -- XXX timv suggests that this should be assocnone for - -- binops as a quick fix. Eventually we should still do - -- this properly. - -- - -- XXX this ought to be derived from the default - -- _pcs_operspec rather than being coded as it is. + -- XXX this ought to be derived from the default + -- _pcs_operspec rather than being coded as it is. [ [ Prefix $ uf (spanned $ bsf $ symbol "new") ] , [ Prefix $ uf (spanned $ prefixOper ) ] , [ Infix (bf (spanned $ normOper )) AssocLeft ] , [ Infix (bf (spanned $ dotOper )) AssocRight ] - , [ Infix (bf (spanned $ commaOper)) AssocRight ] ] + , _pcs_ruleix = 0 } +------------------------------------------------------------------------}}} +-- 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) + ------------------------------------------------------------------------}}} -- Identifier Syles {{{ @@ -305,9 +386,9 @@ dynaAggStyle = IdentifierStyle aggTermSyms :: H.HashSet Char aggTermSyms = H.fromList "=-" -dynaAtomStyle :: TokenParsing m => IdentifierStyle m -dynaAtomStyle = IdentifierStyle - { _styleName = "Atom" +dynaNameStyle :: TokenParsing m => IdentifierStyle m +dynaNameStyle = IdentifierStyle + { _styleName = "Name" , _styleStart = (lower <|> oneOf "$") , _styleLetter = (alphaNum <|> oneOf "_'") , _styleReserved = H.fromList [ "for", "is", "new", "whenever" ] -- XXX maybe not? @@ -315,6 +396,9 @@ dynaAtomStyle = IdentifierStyle , _styleReservedHighlight = ReservedOperator } +name :: (Monad m, TokenParsing m) => m B.ByteString +name = bsf $ ident dynaNameStyle + dynaVarStyle :: TokenParsing m => IdentifierStyle m dynaVarStyle = IdentifierStyle { _styleName = "Variable" @@ -325,15 +409,16 @@ dynaVarStyle = IdentifierStyle , _styleReservedHighlight = ReservedIdentifier } +var :: (Monad m, TokenParsing m) => m B.ByteString +var = bsf $ ident dynaVarStyle ------------------------------------------------------------------------}}} -- Atoms {{{ -atom :: (Monad m, TokenParsing m) => m B.ByteString -atom = liftA BU.fromString stringLiteralSQ - <|> (bsf $ ident dynaAtomStyle) +parseAtom :: (Monad m, TokenParsing m) => m B.ByteString +parseAtom = (liftA BU.fromString stringLiteralSQ <|> name) "Atom" -functor = highlight Identifier atom "Functor" +parseFunctor = highlight Identifier parseAtom "Functor" ------------------------------------------------------------------------}}} -- Terms and term expressions {{{ @@ -344,7 +429,7 @@ nullaryStar = spanned $ flip TFunctor [] <$> (bsf $ string "*") term = token $ choice [ parens tfexpr - , spanned $ TVar <$> (bsf $ ident dynaVarStyle) + , spanned $ TVar <$> var , spanned $ mkta <$> (colon *> term) <* whiteSpace <*> term @@ -352,14 +437,14 @@ term = token $ choice , try $ spanned $ TBase . TNumeric <$> naturalOrDouble - , try $ spanned $ flip TFunctor [] <$> atom + , try $ spanned $ flip TFunctor [] <$> parseAtom <* (notFollowedBy $ char '(') , try $ nullaryStar , spanned $ parenfunc ] where - parenfunc = TFunctor <$> functor + parenfunc = TFunctor <$> parseFunctor <*> parens (tlexpr `sepBy` symbolic ',') mkta ty te = TAnnot (AnnType ty) te @@ -381,12 +466,19 @@ dotOper :: (Monad m, TokenParsing m, LookAheadParsing m) => m B.ByteString dotOper = bsf $ try (lookAhead (thenAny anyChar) *> identNL dynaDotOperStyle) +-- XXX Temporarily eliminated because of confusion with "foo(a,&b)" -- we +-- need to punt this out of the general expression table and down into the +-- "full" table (or perhaps something in-between?) -- it should be OK to +-- write "f(a, (b ,, c))" if ",," is an infix operator, for example, but +-- maybe "f(a, b ,, c )" is a syntax error. +{- -- | 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, LookAheadParsing m) => m B.ByteString commaOper = bsf $ try ( lookAhead (thenAny $ _styleLetter dynaCommaOperStyle) *> identNL dynaCommaOperStyle) + -} -- | A normal operator is handled by trifecta's built-in handling normOper = bsf $ ident dynaOperStyle @@ -413,9 +505,10 @@ tlexpr :: (DeltaParsing m, LookAheadParsing m, MonadReader PCS m) => m (Spanned Term) tlexpr = view pcs_opertab >>= flip buildExpressionParser term . unEOT -moreETable :: DeltaParsing m => [[Operator m (Spanned Term)]] +moreETable :: (LookAheadParsing m, DeltaParsing m) => [[Operator m (Spanned Term)]] moreETable = [ [ Infix (bf (spanned $ bsf $ symbol "is" )) AssocNone ] , [ Infix (bf (spanned $ bsf $ symbol "," )) AssocRight ] + -- , [ Infix (bf (spanned $ commaOper )) AssocRight ] , [ Infix (bf (spanned $ bsf $ symbol "whenever")) AssocNone , Infix (bf (spanned $ bsf $ symbol "for" )) AssocNone ] ] @@ -442,13 +535,14 @@ parseAggr = parseRule :: (DeltaParsing m, LookAheadParsing m, MonadState PCS m) => m Rule -parseRule = choice [ +parseRule = optional whiteSpace + *> choice [ -- HEAD AGGR TFEXPR . try $ rule <*> rs term <* whiteSpace <*> parseAggr <*> rs tfexpr - <*> use pcs_dispostab + <*> pcs_dt -- HEAD . , do @@ -456,25 +550,81 @@ parseRule = choice [ rule <*> pure h <*> pure "&=" <*> pure (TFunctor "true" [] :~ s) - <*> use pcs_dispostab + <*> pcs_dt ] - <* {- optional -} (char '.') + <* {- optional -} (char '.') rawDRule :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Rule) rawDRule = evalStateT (unPCM $ unDL $ spanned parseRule) defPCS +rawDRules :: (DeltaParsing m, LookAheadParsing m) => m [Spanned Rule] +rawDRules = evalStateT (unPCM $ unDL $ many (spanned parseRule <* optional whiteSpace)) defPCS + ------------------------------------------------------------------------}}} -- Pragmas {{{ +-- Inst Declarations {{{ + +instDeclNameStyle = dynaNameStyle + { _styleName = "Inst name" + , _styleReserved = H.fromList $ [ "any" + , "bound" + , "clobbered" + , "mostlyclobbered" + , "free" + , "shared" + , "unique" + , "mostlyunique" + ] + } + +instName = bsf $ ident instDeclNameStyle + +parseInst = choice [ PIVar <$> var + , symbol "free" *> pure (PIInst IFree) + , symbol "any" *> (PIInst . IAny <$> optUniq) + , symbol "ground" *> (PIInst . IUniv <$> optUniq) + , symbol "bound" *> boundinst UShared + + -- Some uniques are acceptable in this context and have + -- slightly different meanings + , symbol "unique" *> choice [ boundinst UUnique + , pure (PIInst (IUniv UUnique)) + ] + , symbol "clobbered" *> pure (PIInst (IUniv UClobbered)) + ] + where + optUniq = parens ( parseUniq ) <|> pure UShared + + -- XXX this $base thing is pretty bad. Suggestions are welcome. + boundinst u = braces $ (PIInst <$>) $ + flip (IBound u) <$> choice [ try (symbol "$base" *> optional semi) *> pure True + , pure False + ] + <*> (M.fromList <$> functinst `sepBy` semi ) + + functinst = (,) <$> parseAtom <*> parens (parseInst `sepBy` comma) + +parseUniq = choice [ symbol "clobbered" *> pure UClobbered + , symbol "mostlyclobbered" *> pure UMostlyClobbered + , symbol "mostlyunique" *> pure UMostlyUnique + , symbol "shared" *> pure UShared + , symbol "unique" *> pure UUnique + ] + +------------------------------------------------------------------------}}} + parsePragma = choice - [ -- symbol "aggr" *> parseAggr -- XXX alternate syntax for aggr - symbol "dispos" *> parseDisposition -- in-place dispositions - , symbol "oper" *> parseOper -- new {pre,in,post}fix oper + [ -- try $ symbol "aggr" *> parseAggr -- XXX alternate syntax for aggr + symbol "dispos" *> parseDisposition -- in-place dispositions + , symbol "inst" *> parseInstDecl -- instance delcarations + , symbol "mode" *> parseMode -- mode/qmode decls + , symbol "oper" *> parseOper -- new {pre,in,post}fix oper ] where parseDisposition = PDispos <$> selfdis - <*> functor - <*> (parens (argdis `sepBy` symbol ",") + <*> parseFunctor + <*> (parens (argdis `sepBy` comma) <|> pure []) where argdis = choice [ symbol "&" *> pure ADQuote @@ -485,6 +635,19 @@ parsePragma = choice , pure SDInherit ] + parseDisposDefl = PDisposDefl <$> + choice [ symbol "prologish" + , symbol "dyna" + , pure "dyna" + ] + + -- XXX Does not handle <= or >= forms yet, which we need for mode + -- polymorphism. + -- + parseInstDecl = PInst <$> parseNameWithArgs instName + <* symbol "==" + <*> parseInst + parseOper = choice [ try $ symbol "add" *> parseOperAdd , try $ symbol "del" *> parseOperDel , parseOperAdd @@ -504,17 +667,25 @@ parsePragma = choice , symbol "in" *> ((,) <$> (PFIn <$> assoc) <*> pure ifx) ] - pfx = choice [ prefixOper, dotOper, commaOper, justAtom ] - ifx = choice [ normOper , dotOper, commaOper, justAtom ] - afx = choice [ prefixOper, normOper, dotOper, commaOper, justAtom] - - justAtom = bsf $ ident dynaAtomStyle + pfx = choice [ prefixOper, dotOper, {- commaOper, -} name ] + ifx = choice [ normOper , dotOper, {- commaOper, -} name ] + afx = choice [ prefixOper, normOper, dotOper, {- commaOper, -} name] assoc = choice [ symbol "none" *> pure PAssocNone , symbol "left" *> pure PAssocLeft , symbol "right" *> pure PAssocRight ] + -- Unlike Mercury, mode declarations are used solely to give names to + -- modes. We separate query modes and update modes out to their own + -- pragmas, qmode and umode. + parseMode = PMode <$> parseNameWithArgs name + <* symbol "==" + <*> (Right <$> parseInst <|> Left <$> parseNameWithArgs instName) + <* symbol ">>" + <*> (Right <$> parseInst <|> Left <$> parseNameWithArgs instName) + + dpragma :: (DeltaParsing m, LookAheadParsing m, MonadReader PCS m) => m Pragma dpragma = symbol ":-" @@ -524,6 +695,42 @@ dpragma = symbol ":-" <* whiteSpace <* {- optional -} (char '.') +pcsProcPragma :: (Parsing m, MonadState PCS m) => Spanned Pragma -> m () +pcsProcPragma (PDispos s f as :~ _) = do + pcs_dt_over %= dtoMerge (f,length as) (s,as) +pcsProcPragma (PDisposDefl n :~ s) = do + pcs_dt_mk .= case n of + "dyna" -> disposTab_dyna + "prologish" -> disposTab_dyna + _ -> dynacPanic $ "Unknown default disposition table:" + PP. PP.pretty n + PP. "at" PP. prettySpanLoc s +pcsProcPragma (PInst (PNWA n as) pi :~ s) = do + im <- use pcs_instmap + maybe (pcs_instmap %= M.insert n (as,pi,s)) + -- XXX fix this error message once the new trifecta lands upstream + -- with its ability to throw Err. + (\(_,_,s') -> unexpected $ "duplicate definition of inst: " + ++ (show n) + ++ "(prior definition at " + ++ (show s') ++ ")" ) + $ M.lookup n im +pcsProcPragma (PMode (PNWA n as) pmf pmt :~ s) = do + mm <- use pcs_modemap + maybe (pcs_modemap %= M.insert n (as,pmf,pmt,s)) + -- XXX fix this error message once the new trifecta lands upstream + -- with its ability to throw Err. + (\(_,_,_,s') -> unexpected $ "duplicate definition of mode: " + ++ (show n) + ++ "(prior definition at " + ++ (show s') ++ ")" ) + $ M.lookup n mm +pcsProcPragma (p :~ s) = dynacSorry $ "Cannot handle pragma" + PP. (PP.text $ show p) + PP. "at" + PP. prettySpanLoc s + + ------------------------------------------------------------------------}}} -- Lines {{{ @@ -537,12 +744,12 @@ progline = whiteSpace rawDLine :: (DeltaParsing m, LookAheadParsing m) => m (Spanned Line) rawDLine = evalStateT (unPCM $ unDL $ progline <* optional whiteSpace) defPCS +-- XXX REWRITE + interpretProgline = do - ls@(l :~ _) <- progline + ls@(l :~ s) <- progline case l of - LPragma (PDispos s f as) -> do - pcs_dispostab %= dtMerge (f,length as) (s,as) - interpretProgline + LPragma p -> pcsProcPragma (p :~ s) >> interpretProgline _ -> return ls dparse = (unPCM $ unDL $ many (interpretProgline <* optional whiteSpace) <* eof) diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index 55c7aed..faeff3a 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -32,7 +32,6 @@ import Text.Trifecta.Delta import Dyna.ParserHS.Parser import Dyna.Term.TTerm (Annotation(..), TBase(..)) -import Dyna.Term.SurfaceSyntax (defDisposTab) import Dyna.XXX.TrifectaTest ------------------------------------------------------------------------}}} @@ -172,35 +171,38 @@ case_tyAnnot = e @=? (term fintx) fintx = "f(:int X)" ------------------------------------------------------------------------}}} --- Rules and lines {{{ +-- Rules {{{ -progline :: ByteString -> Spanned Line -progline = unsafeParse (rawDLine <* eof) +type MRule = (RuleIx, Spanned Term, B.ByteString, Spanned Term) -proglines :: ByteString -> [Spanned Line] -proglines = unsafeParse (rawDLines <* eof) +manglerule :: Rule -> MRule +manglerule (Rule i h a b _) = (i,h,a,b) + +progrule :: ByteString -> Spanned MRule +progrule = fmap manglerule . unsafeParse (rawDRule <* eof) + +progrules :: ByteString -> [Spanned MRule] +progrules = fmap (fmap manglerule) . unsafeParse (rawDRules <* eof) case_ruleFact :: Assertion -case_ruleFact = e @=? (progline sr) +case_ruleFact = e @=? (progrule 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 + e = ( 0 + , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 4 4) sr + , "&=" + , (TFunctor "true" [] :~ Span (Columns 0 0) (Columns 4 4) sr) + ) :~ ts ts = Span (Columns 0 0) (Columns 5 5) sr sr = "goal." case_ruleSimple :: Assertion -case_ruleSimple = e @=? (progline sr) +case_ruleSimple = e @=? (progrule sr) where - 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 + e = ( 0 + , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr + , "+=" + , _tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 9 9) sr + ) :~ ts ts = Span (Columns 0 0) (Columns 10 10) sr sr = "goal += 1." @@ -221,63 +223,59 @@ case_ruleSimple = e @=? (progline sr) -- sr = "goal += 0." case_ruleExpr :: Assertion -case_ruleExpr = e @=? (progline sr) +case_ruleExpr = e @=? (progrule sr) where - e = LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) - "+=" - (TFunctor "+" - [TFunctor "foo" [] :~ Span (Columns 8 8) (Columns 12 12) sr - ,TFunctor "bar" [] :~ Span (Columns 14 14) (Columns 18 18) sr - ] - :~ Span (Columns 8 8) (Columns 18 18) sr - ) - defDisposTab - :~ ts) - :~ ts + e = ( 0 + , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr + , "+=" + , TFunctor "+" + [TFunctor "foo" [] :~ Span (Columns 8 8) (Columns 12 12) sr + ,TFunctor "bar" [] :~ Span (Columns 14 14) (Columns 18 18) sr + ] + :~ Span (Columns 8 8) (Columns 18 18) sr + ) :~ ts ts = Span (Columns 0 0) (Columns 19 19) sr sr = "goal += foo + bar ." case_ruleDotExpr :: Assertion -case_ruleDotExpr = e @=? (progline sr) +case_ruleDotExpr = e @=? (progrule sr) where - e = LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) - "+=" - (TFunctor "." - [TFunctor "foo" [] :~ Span (Columns 8 8) (Columns 11 11) sr - ,TFunctor "bar" [] :~ Span (Columns 12 12) (Columns 15 15) sr - ] - :~ Span (Columns 8 8) (Columns 15 15) sr - ) - defDisposTab - :~ ts) - :~ ts + e = ( 0 + , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr + , "+=" + , TFunctor "." + [TFunctor "foo" [] :~ Span (Columns 8 8) (Columns 11 11) sr + ,TFunctor "bar" [] :~ Span (Columns 12 12) (Columns 15 15) sr + ] + :~ Span (Columns 8 8) (Columns 15 15) sr + ) :~ ts ts = Span (Columns 0 0) (Columns 16 16) sr sr = "goal += foo.bar." case_ruleComma :: Assertion -case_ruleComma = e @=? (progline sr) +case_ruleComma = e @=? (progrule sr) where - e = LRule (Rule 0 (TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 4 4) sr) - "+=" - (TFunctor "," [TFunctor "bar" [TVar "X" :~ Span (Columns 11 11) (Columns 12 12) sr] - :~ Span (Columns 7 7) (Columns 13 13) sr - ,TFunctor "," [TFunctor "baz" [TVar "X" :~ Span (Columns 19 19) (Columns 20 20) sr] - :~ Span (Columns 15 15) (Columns 21 21) 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 + e = ( 0 + , TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 4 4) sr + , "+=" + , TFunctor "," [TFunctor "bar" [TVar "X" :~ Span (Columns 11 11) (Columns 12 12) sr] + :~ Span (Columns 7 7) (Columns 13 13) sr + ,TFunctor "," [TFunctor "baz" [TVar "X" :~ Span (Columns 19 19) (Columns 20 20) sr] + :~ Span (Columns 15 15) (Columns 21 21) 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 + ) :~ ts ts = Span (Columns 0 0) (Columns 25 25) sr sr = "foo += bar(X), baz(X), X." case_ruleKeywordsComma :: Assertion -case_ruleKeywordsComma = e @=? (progline sr) +case_ruleKeywordsComma = e @=? (progrule sr) where - e = LRule (Rule 0 (TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 4 4) sr) - "=" - (TFunctor "whenever" [TFunctor "new" [TVar "X" :~ Span (Columns 10 10) (Columns 12 12) sr] + e = ( 0 + , TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 4 4) sr + , "=" + , TFunctor "whenever" [TFunctor "new" [TVar "X" :~ Span (Columns 10 10) (Columns 12 12) sr] :~ Span (Columns 6 6) (Columns 12 12) sr ,TFunctor "," [TFunctor "is" [TVar "X" :~ Span (Columns 21 21) (Columns 23 23) sr ,TFunctor "baz" [TVar "Y" :~ Span (Columns 30 30) (Columns 31 31) sr] @@ -287,78 +285,68 @@ case_ruleKeywordsComma = e @=? (progline sr) ,_tNumeric (Left 3) :~ Span (Columns 39 39) (Columns 41 41) 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 + :~ Span (Columns 6 6) (Columns 41 41) sr -- End expression + ) :~ ts ts = Span (Columns 0 0) (Columns 42 42) sr sr = "foo = new X whenever X is baz(Y), Y is 3 ." case_rules :: Assertion -case_rules = e @=? (proglines sr) +case_rules = e @=? (progrules sr) where - 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 + e = [ ( 0 + , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr + , "+=" + , _tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 10 10) sr + ) :~ s1 + , ( 1 + , TFunctor "laog" [] :~ Span (Columns 12 12) (Columns 17 17) sr + , "min=" + , _tNumeric (Left 2) :~ Span (Columns 22 22) (Columns 24 24) sr + ) :~ s2 ] s1 = Span (Columns 0 0) (Columns 11 11) sr s2 = Span (Columns 12 12) (Columns 25 25) sr sr = "goal += 1 . laog min= 2 ." case_rulesWhitespace :: Assertion -case_rulesWhitespace = e @=? (proglines sr) +case_rulesWhitespace = e @=? (progrules sr) where - 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 + e = [ ( 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 + ) :~ s1 + , ( 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 + ) :~ s2 ] l0 = " goal%comment\n" l1 = " += 1 .\n" l2 = "%test \n" l3 = " goal += 2 . " - s1 = Span (Columns 2 2) (Lines 1 7 22 7) l0 + s1 = Span (Columns 0 0) (Lines 1 7 22 7) l0 s2 = Span (Lines 3 1 31 1) (Lines 3 12 42 12) l3 sr = B.concat [l0,l1,l2,l3] - case_rulesDotExpr :: Assertion -case_rulesDotExpr = e @=? (proglines sr) +case_rulesDotExpr = e @=? (progrules sr) where - e = [ LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) - "+=" - (TFunctor "." - [TFunctor "foo" [] :~ Span (Columns 8 8) (Columns 11 11) sr - ,TFunctor "bar" [] :~ Span (Columns 12 12) (Columns 15 15) 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 + e = [ ( 0 + , TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr + , "+=" + , TFunctor "." + [TFunctor "foo" [] :~ Span (Columns 8 8) (Columns 11 11) sr + ,TFunctor "bar" [] :~ Span (Columns 12 12) (Columns 15 15) sr + ] + :~ Span (Columns 8 8) (Columns 15 15) sr + ) :~ s1 + , ( 1 + , TFunctor "goal" [] :~ Span (Columns 17 17) (Columns 22 22) sr + , "+=" + , _tNumeric (Left 1) :~ Span (Columns 25 25) (Columns 27 27) sr + ) :~ s2 ] s1 = Span (Columns 0 0) (Columns 16 16) sr s2 = Span (Columns 17 17) (Columns 28 28) sr diff --git a/src/Dyna/Term/SurfaceSyntax.hs b/src/Dyna/Term/SurfaceSyntax.hs index 6d07aba..cb8e2d1 100644 --- a/src/Dyna/Term/SurfaceSyntax.hs +++ b/src/Dyna/Term/SurfaceSyntax.hs @@ -41,50 +41,91 @@ data ArgDispos = ADEval | ADQuote deriving (Eq,Show) -type DisposTab = M.Map (DFunct,Int) (SelfDispos,[ArgDispos]) +type DisposTabOver = M.Map DFunctAr (SelfDispos,[ArgDispos]) + +data DisposTab = DisposTab + { dt_selfEvalDispos :: DFunctAr -> SelfDispos + , dt_argEvalDispos :: DFunctAr -> [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 +dtoMerge :: DFunctAr + -> (SelfDispos,[ArgDispos]) + -> DisposTabOver + -> DisposTabOver +dtoMerge = M.insert +{-# INLINE dtoMerge #-} ------------------------------------------------------------------------}}} -- 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,[])) - ] +-- | Make the default surface syntax look like a kind of prolog with funny +-- operators. In particular all initial-alphanumeric functors inherit and +-- prefer to /quote/ their arguments, while initial-symbolic functors +-- request their own evaluation and the evaluation of their arguments. +-- +-- Notably, TimV seems to prefer this syntax. +disposTab_prologish :: DisposTabOver -> DisposTab +disposTab_prologish t = DisposTab s a + where + s :: (DFunct, Int) -> SelfDispos + s fa = maybe (maybe def fst $ M.lookup fa dt) 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 + + a :: (DFunct, Int) -> [ArgDispos] + a fa = maybe (maybe def snd $ M.lookup fa dt) 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 + + -- A built-in set of defaults, used if we miss the user-provided table + -- but before we fall-back to the default rules. + dt = 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,[])) + ] + +-- | Make the default surface syntax more functional. Here, all functors +-- inherit their self disposition from context and always prefer to evaluate +-- their arguments. +disposTab_dyna :: DisposTabOver -> DisposTab +disposTab_dyna t = DisposTab s a + where + s :: (DFunct, Int) -> SelfDispos + s fa = maybe (maybe SDInherit fst $ M.lookup fa dt) fst $ M.lookup fa t + + a :: (DFunct, Int) -> [ArgDispos] + a fa@(_,arity) = maybe (maybe def snd $ M.lookup fa dt) snd $ M.lookup fa t + where + def = take arity $ repeat ADEval + + -- There are, however, even in this case a few terms we would prefer to + -- behave structurally by default. + dt = M.fromList [ + (("pair" ,2),(SDQuote,[ADEval,ADEval])) + , (("true" ,0),(SDQuote,[])) + , (("false",0),(SDQuote,[])) + ] ------------------------------------------------------------------------}}} ------------------------------------------------------------------------}}}