+++ /dev/null
-
-
-% example of conflicting aggregators
-a += 3.
-a *= 2.
\ No newline at end of file
-
-
-
-
% 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 ]
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 .
% 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.
-- 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)
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
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
$ 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
-}
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
_ -> 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
<+> 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."
------------------------------------------------------------------------}}}
-- <https://github.com/ekmett/trifecta/blob/master/examples/RFC2616.hs>
-- 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.
-- 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 #-}
module Dyna.ParserHS.Parser (
PCS, defPCS,
Term(..), rawDTerm,
- Rule(..), rawDRule, Line(..), rawDLine, rawDLines
+ Rule(..), RuleIx, rawDRule, rawDRules, Line(..), rawDLine, rawDLines
) where
import Control.Applicative
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
-- 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
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 {{{
--
-- 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)
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
-> 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 {{{
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?
, _styleReservedHighlight = ReservedOperator
}
+name :: (Monad m, TokenParsing m) => m B.ByteString
+name = bsf $ ident dynaNameStyle
+
dynaVarStyle :: TokenParsing m => IdentifierStyle m
dynaVarStyle = IdentifierStyle
{ _styleName = "Variable"
, _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 {{{
term = token $ choice
[ parens tfexpr
- , spanned $ TVar <$> (bsf $ ident dynaVarStyle)
+ , spanned $ TVar <$> var
, spanned $ mkta <$> (colon *> term) <* whiteSpace <*> term
, 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
=> 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
=> 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 ]
]
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
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
, 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
, 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 ":-"
<* 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 {{{
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)
import Dyna.ParserHS.Parser
import Dyna.Term.TTerm (Annotation(..), TBase(..))
-import Dyna.Term.SurfaceSyntax (defDisposTab)
import Dyna.XXX.TrifectaTest
------------------------------------------------------------------------}}}
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."
-- 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]
,_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
| 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,[]))
+ ]
------------------------------------------------------------------------}}}
------------------------------------------------------------------------}}}
projects / dyna2 / commitdiff