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
------------------------------------------------------------------------}}}
-- 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.
--
-- | A map from (functor,arity) to self disposition.
, ad_self_dispos :: (DFunct,Int) -> SelfDispos
}
+-}
mergeDispositions :: SelfDispos -> (ECSrc, ArgDispos) -> ArgDispos
mergeDispositions = md
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 {{{
-- 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)
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
}
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
-- | 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 {{{
-- 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 #-}
{-# 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
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 {{{
-- 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 {{{
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 {{{
, _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
}
-------------------------------------------------------------------------}}}
--- 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 {{{
atom = liftA BU.fromString stringLiteralSQ
<|> (bsf $ ident dynaAtomStyle)
+functor = highlight Identifier atom <?> "Functor"
+
------------------------------------------------------------------------}}}
-- Terms and term expressions {{{
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 ',')
(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
------------------------------------------------------------------------}}}
import Dyna.ParserHS.Parser
import Dyna.Term.TTerm (Annotation(..), TBase(..))
+import Dyna.Term.SurfaceSyntax (defDisposTab)
import Dyna.XXX.TrifectaTest
------------------------------------------------------------------------}}}
_tNumeric = TBase . TNumeric
term :: ByteString -> Spanned Term
-term = unsafeParse dterm
+term = unsafeParse (rawDTerm <* eof)
case_basicAtom :: Assertion
case_basicAtom = e @=? (term "foo")
-- gs = "gensym(*)"
case_failIncompleteExpr :: Assertion
-case_failIncompleteExpr = checkParseFail dterm "foo +"
+case_failIncompleteExpr = checkParseFail rawDTerm "foo +"
"(interactive):1:5: error: expected: \"(\",\nend of input\nfoo +<EOF> \n ^ "
------------------------------------------------------------------------}}}
-- 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
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
]
:~ Span (Columns 8 8) (Columns 18 18) sr
)
+ defDisposTab
:~ ts)
:~ ts
ts = Span (Columns 0 0) (Columns 19 19) sr
]
:~ Span (Columns 8 8) (Columns 15 15) sr
)
+ defDisposTab
:~ ts)
:~ ts
ts = Span (Columns 0 0) (Columns 16 16) 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
:~ 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
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 = [ 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
]
]
:~ 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
]
--- /dev/null
+---------------------------------------------------------------------------
+-- | 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,[]))
+ ]
+
+------------------------------------------------------------------------}}}
+------------------------------------------------------------------------}}}
projects / dyna2 / commitdiff