penrose-0.1.1.1: src/Penrose/Style.hs
-- | The "Style" module contains the compiler for the Style language,
-- and functions to traverse the Style AST.
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction, FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
-- Mostly for autodiff
module Penrose.Style where
import Control.Applicative ((<**>))
import Control.Applicative.Permutations
import Control.Monad (foldM, void)
import Control.Monad.Combinators.Expr
import Control.Monad.State.Lazy (evalStateT, get)
import Data.Dynamic
import Data.Either (partitionEithers)
import Data.Either.Extra (fromLeft)
import Data.Function (on)
import Data.List (intercalate, nub, nubBy,
partition, sort)
import qualified Data.Map.Strict as M
import Data.Maybe (catMaybes, fromMaybe,
isNothing, maybeToList)
import Data.Tuple (swap)
import Data.Typeable
import Debug.Trace
import Penrose.Env
import Penrose.Functions
import Penrose.Shapes hiding (get)
import qualified Penrose.Substance as C
import Penrose.SubstanceJSON as J
import Penrose.Util
import System.Environment
import System.Random
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Show.Pretty (ppShow)
--------------------------------------------------------------------------------
-- Plugin Parser
-- | A Style program can have an instantiator, which would expand its corresponding Substance program via an external program. The instantiator is specified with a string
-- NOTE: for now, we would allow multiple instantiation statements, but only use the __first__ instantiator in the Style program
type Plugin = String
type Plugins = [Plugin]
-- | 'parsePlugins' parses a Style program and return a list of instantiators declared at the __top__ of the program.
-- NOTE: this parse do run the Style parser to check for ill-formed instantiation statements. Therefore, a 'VarEnv' is required to run this parser without any errors
parsePlugins :: String -> String -> VarEnv -> Either CompilerError Plugins
parsePlugins styFile styIn env =
case runParser (pluginParser env) styFile styIn of
Left err -> Left $ PluginParse $ (errorBundlePretty err)
Right instantiation -> Right instantiation
pluginParser :: VarEnv -> BaseParser Plugins
pluginParser env = evalStateT pluginParser' $ Just env
pluginParser' :: Parser Plugins
pluginParser' = do
scn
res <- plugins
_ <- styProg
return res
where restOfFile = manyTill anySingle eof >> return []
plugins :: Parser Plugins
plugins = plugin `endBy` newline' -- zero or multiple instantiators
plugin :: Parser Plugin
plugin = symbol "plugin" >> stringLiteral
stringLiteral :: Parser String
stringLiteral = symbol "\"" >> manyTill L.charLiteral (try (symbol "\""))
--------------------------------------------------------------------------------
-- Style AST
-------------------- Style Program grammar
-- | A variable in Style
newtype StyVar = StyVar' String
deriving (Show, Eq, Ord, Typeable)
-- | A header of a block is either a selector or a namespace declaration
data Header = Select Selector | Namespace StyVar
deriving (Show, Eq, Typeable)
-- | A Style block contains a list of statements
type Block = [Stmt]
-- | A Style program is a collection of (header, block) pairs
type StyProg = [(Header, Block)]
-------------------- Style selector grammar
-- TODO: write a NOTE about the namespace situation between Substance and Style.
data STypeVar = STypeVar' {
typeVarNameS :: String,
typeVarPosS :: SourcePos
} deriving (Eq, Typeable)
instance Show STypeVar where
show = show . typeVarNameS
-- | A type in Style can be TODO (Alias because of T in `Env`)
data StyT = STTypeVar STypeVar
| STCtor STypeCtor
deriving (Show, Eq, Typeable)
data STypeCtor = STypeCtor {
nameConsS :: String,
argConsS :: [SArg],
posConsS :: SourcePos
} deriving (Eq, Typeable)
instance Show STypeCtor where
show t = show (nameConsS t) ++ show (argConsS t)
data SArg
= SAVar BindingForm
| SAT StyT
deriving (Show, Eq, Typeable)
data SelExpr
= SEBind BindingForm
| SEAppFunc String [SelExpr]
| SEAppValCons String [SelExpr]
deriving (Show, Eq, Typeable)
data PredArg
= PE SelExpr -- TODO: this should only be allowed to be a Var in Sub (and maybe in Sty?)
| PP Predicate
deriving (Show, Eq, Typeable)
data Predicate = Predicate {
predicateName :: String,
predicateArgs :: [PredArg],
predicatePos :: SourcePos
} deriving (Eq, Typeable)
instance Show Predicate where
show t = show (predicateName t) ++ show (predicateArgs t)
-- | A binding form can either be a newly declared Style id or an existing
-- Substance id, which is denoted by the special @``@ characters
data BindingForm = BSubVar Var | BStyVar StyVar
deriving (Show, Eq, Ord, Typeable)
data DeclPattern = PatternDecl' StyT BindingForm
deriving (Show, Eq, Typeable)
data RelationPattern = RelBind BindingForm SelExpr | RelPred Predicate
deriving (Show, Eq, Typeable)
-- | A selector is TODO
data Selector = Selector {
selHead :: [DeclPattern],
selWith :: [DeclPattern],
selWhere :: [RelationPattern],
selNamespace :: Maybe String
} deriving (Show, Eq, Typeable)
-------------------- Style block grammar
type Field = String
-- | A path consist of a Substance or Style id, a shape name, and (optionally)
-- a property name
data Path
= FieldPath BindingForm Field -- example: x.val
| PropertyPath BindingForm Field Property -- example: x.shape.center
-- NOTE: Style writer must use backticks in the block to indicate Substance variables
deriving (Show, Eq, Typeable, Ord)
-- | A statement in the Style language
data Stmt
= Assign Path Expr
| Override Path Expr
| Delete Path
deriving (Show, Eq, Typeable)
-- | A field declaration in a Style constructor binds an expression to a
-- string
data PropertyDecl = PropertyDecl String Expr
deriving (Show, Eq, Typeable)
data AnnoFloat = Fix Float | Vary
deriving (Show, Eq, Typeable)
-- | An expression in the Style language
data Expr
= IntLit Integer
| AFloat AnnoFloat
| StringLit String
| BoolLit Bool
| EPath Path
| CompApp String [Expr]
| ObjFn String [Expr]
| ConstrFn String [Expr]
| AvoidFn String [Expr] -- TODO: to be implemented
| BinOp BinaryOp Expr Expr
| UOp UnaryOp Expr
| List [Expr]
| Tuple Expr Expr
| ListAccess Path Integer
| Ctor String [PropertyDecl] -- Shouldn't be using this, since we have PropertyDict
| Layering Path Path -- ^ first GPI is *below* the second GPI
| PluginAccess String Expr Expr -- ^ Plugin name, Substance name, Key
| ThenOp Expr Expr -- COMBAK: double check how transforms are modeled, probably just a list of CompApp
deriving (Show, Eq, Typeable)
data LayerOp = Less | Seq
deriving (Show, Eq, Typeable)
data UnaryOp = UPlus | UMinus
deriving (Show, Eq, Typeable)
data BinaryOp = BPlus | BMinus | Multiply | Divide | Exp
deriving (Show, Eq, Typeable)
--------------------------------------------------------------------------------
-- Style Parser
-- | 'parseStyle' runs the actual parser function: 'styleParser', taking in a program String and parse it into an AST.
parseStyle :: String -> String -> VarEnv -> Either CompilerError StyProg
parseStyle styFile styIn env =
case runParser (styleParser env) styFile styIn of
Left err -> Left $ StyleParse $ (errorBundlePretty err)
Right res -> Right res
-- | 'styleParser' is the top-level function that parses a Style proram
styleParser :: VarEnv -> BaseParser StyProg
styleParser env = evalStateT styleParser' $ Just env
styleParser' = between scn eof styProg
-- | `styProg` parses a Style program, consisting of a collection of one or
-- more blocks
styProg :: Parser StyProg
styProg =
plugins >> -- ignore plugin statements
some headerBlock
where headerBlock = (,) <$> header <*> braces block <* scn
header :: Parser Header
header = tryChoice [Select <$> selector, Namespace <$> styVar]
-------------------- Selector parsers
-- COMBAK: short-hand for decls with the same type
-- COMBAK: change commas to semicolons
-- TODO: clear up the `scn` calls for all parsers and establish the convention of calling scn AFTER each parser
selector :: Parser Selector
selector = do
hd <- fmap concat $ declPattern `sepBy1` semi' <* scn
(wi, wh) <- withAndWhere
ns <- optional $ namespace <* scn
return Selector { selHead = hd, selWith = wi, selWhere = wh,
selNamespace = ns}
where wth = fmap concat $ rword "with" *> declPattern `sepEndBy1` semi' <* scn
whr = rword "where" *> relationPattern `sepEndBy1` semi' <* scn
namespace = rword "as" >> identifier
withAndWhere = runPermutation $ (,) <$> toPermutationWithDefault [] wth <*> toPermutationWithDefault [] whr
styVar :: Parser StyVar
styVar = StyVar' <$> identifier
declPattern :: Parser [DeclPattern]
declPattern = do
t <- styType
ns <- bindingForm `sepBy1` comma
return $ map (PatternDecl' t) ns
styType :: Parser StyT
styType = STTypeVar <$> typeVar <|> STCtor <$> typeConstructor
typeVar :: Parser STypeVar
typeVar = do
aps -- COMBAK: get rid of this later once it's consistent with DSLL/Substance
t <- identifier
pos <- getSourcePos
return STypeVar' { typeVarNameS = t, typeVarPosS = pos}
typeConstructor :: Parser STypeCtor
typeConstructor = do
n <- identifier
args <- option [] $ parens (styArgument `sepBy1` comma)
pos <- getSourcePos
return STypeCtor { nameConsS = n, argConsS = args, posConsS = pos }
-- COMBAK: styType will probably not work because of recursion. Test this explicitly
styArgument :: Parser SArg
styArgument = SAVar <$> bindingForm <|> SAT <$> styType
relationPattern :: Parser RelationPattern
relationPattern = try pre <|> bind
where bind = RelBind <$> bindingForm <*> (def >> selectorExpr)
pre = RelPred <$> predicate
predicate :: Parser Predicate
predicate = do
n <- identifier
args <- parens $ predicateArgument `sepBy1` comma
pos <- getSourcePos
return Predicate { predicateName = n, predicateArgs = args,
predicatePos = pos }
predicateArgument :: Parser PredArg
predicateArgument = PE <$> selectorExpr <|> PP <$> predicate
selectorExpr :: Parser SelExpr
selectorExpr =
try selectorValConsOrFunc <|>
SEBind <$> bindingForm
bindingForm :: Parser BindingForm
bindingForm = BSubVar <$> backticks varParser <|> BStyVar <$> styVar
-- NOTE: this is a duplication of "valConsOrFunc" in Substance parser, with selector specific types
selectorValConsOrFunc :: Parser SelExpr
selectorValConsOrFunc = do
n <- identifier
e <- get
let env = fromMaybe (error "Style parser: variable environment is not intiialized.") e
args <- parens (selectorExpr `sepBy1` comma)
case (M.lookup n $ valConstructors env, M.lookup n $ operators env) of
-- the id is a value constructor
(Just _, Nothing) -> return $ SEAppValCons n args
-- the id is an operator
(Nothing, Just _) -> return $ SEAppFunc n args
(Nothing, Nothing) -> styleErr $ "undefined identifier " ++ n
_ -> styleErr $ n ++ " cannot be both a value constructor and an operator"
where styleErr s = customFailure (StyleError s)
-------------------- Block parsers
block :: Parser [Stmt]
block = stmt `sepEndBy` newline'
stmt :: Parser Stmt
stmt = tryChoice [assign, override, delete]
assign, override, delete :: Parser Stmt
assign = Assign <$> path <*> (eq >> expr)
override = Override <$> (rword "override" >> path) <*> (eq >> expr)
delete = Delete <$> (rword "delete" >> path)
expr :: Parser Expr
expr = tryChoice [
constructor,
layeringExpr,
arithmeticExpr,
objFn,
constrFn,
transformExpr, -- COMBAK: ordering
compFn,
list,
tuple,
stringLit,
boolLit
]
pluginAccess :: Parser Expr
pluginAccess = do
plugin <- identifier
name <- bExpr
key <- bExpr
return $ PluginAccess plugin name key
where bExpr = brackets expr
arithmeticExpr :: Parser Expr
arithmeticExpr = makeExprParser aTerm aOperators
aTerm :: Parser Expr
aTerm = tryChoice
[
compFn,
pluginAccess,
parens arithmeticExpr,
AFloat <$> annotatedFloat,
EPath <$> path,
IntLit <$> integer
]
aOperators :: [[Control.Monad.Combinators.Expr.Operator Parser Expr]]
aOperators =
[ -- Highest precedence
[
Prefix (UOp UMinus <$ symbol "-"),
Prefix (UOp UPlus <$ symbol "+")
],
[ InfixL (BinOp Exp <$ symbol "^") ],
[
InfixL (BinOp Multiply <$ symbol "*"),
InfixL (BinOp Divide <$ symbol "/")
],
[
InfixL (BinOp BPlus <$ symbol "+"),
InfixL (BinOp BMinus <$ symbol "-")
]
-- Lowest precedence
]
layeringExpr :: Parser Expr
layeringExpr = try layeringAbove <|> layeringBelow
where
layeringBelow = Layering <$> path <* rword "below" <*> path
layeringAbove = do
path1 <- path
rword "above"
path2 <- path
return $ Layering path2 path1
transformExpr :: Parser Expr
transformExpr = makeExprParser tTerm tOperators
tTerm :: Parser Expr
tTerm = compFn
tOperators :: [[Control.Monad.Combinators.Expr.Operator Parser Expr]]
tOperators =
[ -- Highest precedence
[ InfixL (ThenOp <$ symbol "then") ]
-- Lowest precedence
]
path :: Parser Path
path = try (PropertyPath <$> bindingForm <*> dotId <*> dotId) <|>
FieldPath <$> bindingForm <*> dotId
where dotId = dot >> identifier
compFn, objFn, constrFn :: Parser Expr
compFn = CompApp <$> identifier <*> exprsInParens
objFn = ObjFn <$> (rword "encourage" >> identifier) <*> exprsInParens
constrFn = ConstrFn <$> (rword "ensure" >> identifier) <*> exprsInParens
exprsInParens = parens $ expr `sepBy` comma
list, tuple :: Parser Expr
list = List <$> brackets (expr `sepBy1` comma)
tuple = parens (Tuple <$> expr <*> (comma >> expr))
constructor :: Parser Expr
constructor = do
typ <- identifier
fields <- braces (propertyDecl `sepEndBy` newline')
return $ Ctor typ fields
propertyDecl :: Parser PropertyDecl
propertyDecl = PropertyDecl <$> identifier <*> (colon >> expr)
boolLit :: Parser Expr
boolLit = (rword "True" >> return (BoolLit True))
<|> (rword "False" >> return (BoolLit False))
stringLit :: Parser Expr
-- NOTE: overlapping parsers 'charLiteral' and 'char '"'', so we use 'try'
stringLit = StringLit <$> (symbol "\"" >> manyTill L.charLiteral (try (symbol "\"")))
annotatedFloat :: Parser AnnoFloat
annotatedFloat = (question *> pure Vary) <|> Fix <$> float
------------------------------------------------------------------------
-------- STYLE COMPILER
----- Debug info
debugM1, debugM2, debugM3 :: Bool
debugM1 = False
debugM2 = False
debugM3 = False
mkTr :: Bool -> String -> a -> a
mkTr flag str res = if flag then trace str res else res
-- matching
trM1 = mkTr debugM1
-- statics
trM2 = mkTr debugM2
-- translation
trM3 = mkTr debugM3
-- Style static semantics for selectors
------------ Type defs
-- g ::= B => |T
-- Assumes nullary type constructors (i.e. Style type = Substance type)
data SelEnv = SelEnv { sTypeVarMap :: M.Map BindingForm StyT, -- B : |T
sErrors :: [String] }
deriving (Show, Eq, Typeable)
type Error = String
------------ Helper functions on envs
initSelEnv :: SelEnv
initSelEnv = SelEnv { sTypeVarMap = M.empty, sErrors = [] }
-- g, x : |T
addMapping :: BindingForm -> StyT -> SelEnv -> SelEnv
addMapping k v m = m { sTypeVarMap = M.insert k v (sTypeVarMap m) }
addErr :: Error -> SelEnv -> SelEnv
addErr err selEnv = selEnv { sErrors = err : sErrors selEnv }
addErrs :: [Error] -> SelEnv -> SelEnv
addErrs errs selEnv = selEnv { sErrors = sErrors selEnv ++ errs }
-- TODO: don't merge the varmaps! just put g as the varMap (otherwise there will be extraneous bindings for the relational statements)
-- Judgment 1. G || g |-> ...
mergeEnv :: VarEnv -> SelEnv -> VarEnv
mergeEnv varEnv selEnv = foldl mergeMapping varEnv (M.assocs $ sTypeVarMap selEnv)
where mergeMapping :: VarEnv -> (BindingForm, StyT) -> VarEnv
-- G || (x : |T) |-> G
mergeMapping varEnv (BSubVar var, styType) = varEnv
-- G || (y : |T) |-> G[y : T] (shadowing any existing Sub vars)
mergeMapping varEnv (BStyVar (StyVar' var), styType) =
varEnv { varMap = M.insert (VarConst var) (toSubType styType) (varMap varEnv) }
----------- Converting Style values to Env/Substance values for two reasons:
-- 1. so they can be put into Gamma, 2. so the normal Substance judgments can be reused (e.g. T : type)
-- | All Style variables "y" are converted to Substance vars "`x`"
toSubVar :: BindingForm -> Var
toSubVar (BSubVar subv) = subv
toSubVar (BStyVar (StyVar' styv)) = VarConst styv
toSubTArg :: SArg -> Arg
toSubTArg (SAVar bVar) = AVar $ toSubVar bVar
toSubTArg (SAT styT) = AT $ toSubType styT
-- | Convert a Style type to a Substance type. (This has nothing to do with subtyping)
toSubType :: StyT -> T
toSubType (STTypeVar stvar) = TTypeVar $ TypeVar { typeVarName = typeVarNameS stvar,
typeVarPos = typeVarPosS stvar }
toSubType (STCtor stcons) = TConstr $ TypeCtorApp { nameCons = nameConsS stcons,
argCons = map toSubTArg $ argConsS stcons,
constructorInvokerPos = posConsS stcons }
toSubExpr :: SelExpr -> C.Expr
toSubExpr (SEBind bvar) = C.VarE $ toSubVar bvar
toSubExpr (SEAppFunc f exprs) = C.ApplyFunc $ C.Func { C.nameFunc = f, C.argFunc = map toSubExpr exprs }
toSubExpr (SEAppValCons v exprs) = C.ApplyValCons $ C.Func { C.nameFunc = v, C.argFunc = map toSubExpr exprs }
toSubPredArg :: PredArg -> C.PredArg
toSubPredArg (PE selExpr) = C.PE $ toSubExpr selExpr
toSubPredArg (PP pred) = C.PP $ toSubPred pred
toSubPred :: Predicate -> C.Predicate
toSubPred stypred = C.Predicate { C.predicateName = C.PredicateConst $ predicateName stypred,
C.predicateArgs = map toSubPredArg $ predicateArgs stypred,
C.predicatePos = predicatePos stypred }
----------- Selector static semantics
-- For `B := E`, make sure `B : T` and `E : T`
compareTypes :: RelationPattern -> BindingForm -> SelExpr -> Maybe T -> Maybe T -> Maybe Error
compareTypes stmt var expr vtype etype =
case (vtype, etype) of
(Nothing, Nothing) ->
Just $ "In Style statement '" ++ show stmt ++ "', the var and expr" ++ " are both of invalid type."
(Just vtype', Nothing) ->
Just $ "In Style statement '" ++ show stmt ++ "', the expr '" ++ show expr ++
" should have type '" ++ show vtype' ++ "' but does not have a type."
(Nothing, Just etype') ->
Just $ "In Style statement '" ++ show stmt ++ "', the var '" ++ show var ++
" should have type '" ++ show etype' ++ "' but does not have a type."
(Just vtype', Just etype') ->
if typesEq (trM2 ("VTYPE: " ++ show vtype') vtype') (trM2 ("ETYPE: " ++ show etype') etype') then Nothing
else Just $ "In Style statement '" ++ show stmt ++ "', the var and expr" ++
" should have the same type, but have types '" ++ show vtype' ++
"' and '" ++ show etype' ++ "'."
-- Judgment 5. G |- [|S_r] ok
checkRelPatterns :: VarEnv -> [RelationPattern] -> [Error]
checkRelPatterns varEnv rels = concatMap (checkRelPattern varEnv) rels
-- Judgment 4. G |- |S_r ok
where checkRelPattern :: VarEnv -> RelationPattern -> [Error]
checkRelPattern varEnv rel =
case rel of
-- rule Bind-Context
RelBind bVar sExpr ->
-- TODO: use checkSubStmt here (and in paper)?
-- TODO: make sure the ill-typed bind selectors fail here (after Sub statics is fixed)
-- G |- B : T1
let (error1, vtype) = C.checkVarE varEnv
(trM2 ("B: " ++ show (toSubVar bVar)) $ toSubVar bVar) in
-- G |- E : T2
let (error2, etype) = C.checkExpression varEnv
(trM2 ("E: " ++ show (toSubExpr sExpr)) $ toSubExpr sExpr) in
-- T1 = T2
let err3 = compareTypes rel bVar sExpr vtype etype in
case trM2 ("ERR3: " ++ show err3) err3 of
Nothing -> [error1, error2]
Just e3 -> [error1, error2, e3]
-- rule Pred-Context
RelPred pred ->
-- G |- Q : Prop
let varEnv' = C.checkPredicate varEnv $ toSubPred pred in
[errors varEnv']
-- Judgment 6. G; g |- [|S_o] ~> g'
checkDeclPatterns :: VarEnv -> SelEnv -> [DeclPattern] -> SelEnv
checkDeclPatterns varEnv selEnv decls = foldl (checkDeclPattern varEnv) selEnv decls
-- Judgment 3. G; g |- |S_o ok ~> g'
where checkDeclPattern :: VarEnv -> SelEnv -> DeclPattern -> SelEnv
checkDeclPattern varEnv selEnv stmt@(PatternDecl' styType bVar) =
-- G |- |T : type
let errT = errors $ checkT varEnv (toSubType styType) in
let selEnv' = addErr errT selEnv in
case bVar of
-- rule Decl-Sty-Context
bsv@(BStyVar (StyVar' styVar)) ->
-- NOTE: this does not aggregate *all* possible error May just return first error.
-- y \not\in dom(g)
if M.member bsv (sTypeVarMap selEnv')
then let err = "Style pattern statement " ++ show stmt ++
" declares Style variable '" ++ styVar ++ "' twice"
in addErr err selEnv'
else if M.member (BSubVar (VarConst styVar)) (sTypeVarMap selEnv')
then let err = "Style pattern statement " ++ show stmt ++
" declares Style variable '" ++ styVar ++ "'" ++
" in the same selector as a Substance variable of the same name"
in addErr err selEnv'
else addMapping bsv styType selEnv'
-- rule Decl-Sub-Context
bsv@(BSubVar subVar@(VarConst sVar)) ->
-- x \not\in dom(g)
if M.member bsv (sTypeVarMap selEnv')
then let err = "Style pattern statement " ++ show stmt ++
" declares Substance variable '" ++ sVar ++ "' twice"
in addErr err selEnv'
else if M.member (BStyVar (StyVar' sVar)) (sTypeVarMap selEnv')
then let err = "Style pattern statement " ++ show stmt ++
" declares Substance variable '" ++ sVar ++ "'" ++
" in the same selector as a Style variable of the same name"
in addErr err selEnv'
else
-- G(x) = T
let subType = M.lookup subVar $ varMap varEnv in
case subType of
Nothing -> let err = "Substance variable '" ++ show subVar ++
"' does not exist in environment. \n" {- ++ show varEnv -} in
addErr err selEnv'
Just subType' ->
-- check "T <: |T", assuming type constructors are nullary
let declType = toSubType styType in
if subType' == declType
|| isSubtype subType' declType varEnv
then addMapping bsv styType selEnv'
else let err = "Mismatched types between Substance and Style var\n" ++
"Sub var '" ++ show subVar ++ "' has type '" ++ show subType' ++
"in Substance but has type '" ++ show declType ++ "' in Style."
in addErr err selEnv'
-- Judgment 7. G |- Sel ok ~> g
checkSel :: VarEnv -> Selector -> SelEnv
checkSel varEnv sel =
-- Check head statements
let selEnv_afterHead = checkDeclPatterns varEnv initSelEnv (selHead sel) in
-- Check `with` statements
let selEnv_decls = checkDeclPatterns varEnv selEnv_afterHead (selWith sel) in
-- Check relational statements
let rel_errs = checkRelPatterns (mergeEnv varEnv selEnv_decls) (selWhere sel) in
selEnv_decls { sErrors = filter (/= "") $ reverse (sErrors selEnv_decls) ++ rel_errs }
checkNamespace :: String -> VarEnv -> SelEnv
checkNamespace name varEnv =
-- A Substance variable cannot have the same name as a namespace
let error = if M.member (VarConst name) (varMap varEnv)
then ["Substance variable '" ++ name ++ "' has the same name as a namespace in the Style program"]
else []
in addErrs error initSelEnv
-- Returns a sel env for each selector in the Style program, in the same order
-- TODO: add these judgments to the paper
checkSels :: VarEnv -> StyProg -> [SelEnv]
checkSels varEnv prog =
let selEnvs = map (checkPair varEnv) prog in
let errors = concatMap sErrors selEnvs in
if null errors
then selEnvs
else error $ intercalate "\n" errors
where checkPair :: VarEnv -> (Header, Block) -> SelEnv
checkPair varEnv (Select sel, _) = checkSel varEnv sel
checkPair varEnv (Namespace (StyVar' name), _) = checkNamespace name varEnv
-- TODO: for now, namespace has no local context
-- TODO: namespaces are implicitly converted to Substance variables somewhere (not sure where)
-- TODO: write test cases (including failing ones) after Substance errors are no longer @ runtime
-- TODO: get line/col numbers for errors
----------- Selector dynamic semantics (matching)
----- Type declarations
-- A substitution θ has form [y → x], binding Sty vars to Sub vars (currently not expressions).
type Subst = M.Map StyVar Var
type LocalVarId = (Int, Int)
-- Index of the block, paired with the index of the current substitution
-- Should be unique across blocks and substitutions
localKeyword :: String
localKeyword = "LOCAL"
mkLocalVarName :: LocalVarId -> String
mkLocalVarName (blockNum, substNum) = localKeyword ++ "_b" ++ show blockNum ++ "_s" ++ show substNum
----- Substitution helper functions
-- (+) operator combines two substitutions: subst -> subst -> subst
combine :: Ord k => M.Map k a -> M.Map k a -> M.Map k a
combine s1 s2 = M.union s1 s2
-- TODO check for duplicate keys (and vals)
-- (x) operator combines two lists of substitutions: [subst] -> [subst] -> [subst]
-- the way merge is used, I think each subst in the second argument only contains one mapping
merge :: Ord k => [M.Map k a] -> [M.Map k a] -> [M.Map k a]
merge s1 [] = s1
merge [] s2 = s2
merge s1 s2 = [ combine s1i s2j | s1i <- s1, s2j <- s2 ] -- TODO check wrt maps
allUnique :: Eq a => [a] -> Bool
allUnique l = nub l == l
isStyVar :: BindingForm -> Bool
isStyVar (BStyVar _) = True
isStyVar (BSubVar _) = False
-- Judgment 20. A substitution for a selector is only correct if it gives exactly one
-- mapping for each Style variable in the selector.
fullSubst :: SelEnv -> Subst -> Bool
fullSubst selEnv subst =
let selStyVars = map styVarToString $ filter isStyVar $ M.keys $ sTypeVarMap selEnv
substStyVars = map styVarToString' $ M.keys subst
res = sort selStyVars == sort substStyVars in
-- Equal up to permutation (M.keys ensures that there are no dups)
trM1 ("fullSubst: \nselEnv: " ++ ppShow selEnv ++ "\nsubst: " ++ ppShow subst ++ "\nres: " ++ ppShow res ++ "\n") res
where styVarToString (BStyVar (StyVar' v)) = v
styVarToString' (StyVar' v) = v
-- Check that there are no duplicate keys or vals in the substitution
uniqueKeysAndVals :: Subst -> Bool
uniqueKeysAndVals subst =
let (keys, vals) = unzip $ M.toList subst in
allUnique keys && allUnique vals
-- if not (allUnique keys && allUnique vals)
-- then error ("substitution contains some duplicated keys or vals:\n" ++ show keys ++ "\n" ++ show vals)
-- else True
----- Apply a substitution to various parts of Style (relational statements, exprs, blocks)
-- Recursively walk the tree, looking up and replacing each Style variable encountered with a Substance variable
-- If a Sty var doesn't have a substitution (i.e. substitution map is bad), keep the Sty var and move on
-- TODO: return "maybe" if a substitution fails?
substituteBform :: Maybe LocalVarId -> Subst -> BindingForm -> BindingForm
-- Variable in backticks in block or selector (e.g. `X`)
substituteBform _ subst sv@(BSubVar _) = sv
-- If the Style variable is "LOCAL", then resolve it to a unique id for the block and selector
-- Otherwise, look up the substitution for the Style variable and return a Substance variable
substituteBform lv subst sv@(BStyVar sv'@(StyVar' vn)) =
if vn == localKeyword
then case lv of
-- lv = Nothing: substituting into selector, so local vars don't matter
-- lv = Just (i, j): substituting into block, so local vars matter
Nothing -> error "LOCAL keyword found without a subst/block id. It should not be used in a selector."
Just localVarId -> BSubVar $ VarConst $ mkLocalVarName localVarId
else case M.lookup sv' subst of
Just subVar -> BSubVar subVar -- Returns result of mapping if it exists (y -> x)
Nothing -> sv -- error $ "No subst found for Sty var '" ++ vn ++ "'"
-- TODO: no substitutions for namespaces
substituteExpr :: Subst -> SelExpr -> SelExpr
-- theta(B) = ...
substituteExpr subst (SEBind bvar) = SEBind $ substituteBform Nothing subst bvar
-- theta(f[E]) = f([theta(E)]
substituteExpr subst (SEAppFunc fname exprs) = SEAppFunc fname $ map (substituteExpr subst) exprs
-- theta(v([E])) = v([theta(E)])
substituteExpr subst (SEAppValCons vname exprs) = SEAppValCons vname $ map (substituteExpr subst) exprs
substitutePredArg :: Subst -> PredArg -> PredArg
substitutePredArg subst (PE expr) = PE $ substituteExpr subst expr
substitutePredArg subst (PP pred) = PP $ substitutePred subst pred
substitutePred :: Subst -> Predicate -> Predicate
substitutePred subst pred = pred { predicateArgs = map (substitutePredArg subst) $ predicateArgs pred }
-- theta(|S_r) = ...
substituteRel :: Subst -> RelationPattern -> RelationPattern
-- theta(B := E) |-> theta(B) := theta(E)
substituteRel subst (RelBind bvar sExpr) = RelBind (substituteBform Nothing subst bvar)
(substituteExpr subst sExpr)
-- theta(Q([a]) = Q([theta(a)])
substituteRel subst (RelPred pred) = RelPred $ substitutePred subst pred
-- Applies a substitution to a list of relational statement theta([|S_r])
-- TODO: assumes a full substitution
substituteRels :: Subst -> [RelationPattern] -> [RelationPattern]
substituteRels subst rels = map (substituteRel subst) rels
----- Substs for the translation semantics (more tree-walking on blocks, just changing binding forms)
substitutePath :: LocalVarId -> Subst -> Path -> Path
substitutePath lv subst path =
case path of
FieldPath bVar field -> FieldPath (substituteBform (Just lv) subst bVar) field
PropertyPath bVar field prop -> PropertyPath (substituteBform (Just lv) subst bVar) field prop
substituteField :: LocalVarId -> Subst -> PropertyDecl -> PropertyDecl
substituteField lv subst (PropertyDecl field expr) = PropertyDecl field $ substituteBlockExpr lv subst expr
-- DEPRECATED
-- substituteLayering :: LocalVarId -> Subst -> LExpr -> LExpr
-- substituteLayering lv subst (LId bVar) = LId $ substituteBform (Just lv) subst bVar
-- substituteLayering lv subst (LPath path) = LPath $ substitutePath lv subst path
-- substituteLayering lv subst (LayeringOp op lex1 lex2) =
-- LayeringOp op (substituteLayering lv subst lex1) (substituteLayering lv subst lex1)
substituteBlockExpr :: LocalVarId -> Subst -> Expr -> Expr
substituteBlockExpr lv subst expr =
case expr of
EPath path -> EPath $ substitutePath lv subst path
CompApp f es -> CompApp f $ map (substituteBlockExpr lv subst) es
ObjFn f es -> ObjFn f $ map (substituteBlockExpr lv subst) es
ConstrFn f es -> ConstrFn f $ map (substituteBlockExpr lv subst) es
AvoidFn f es -> AvoidFn f $ map (substituteBlockExpr lv subst) es
BinOp op e1 e2 -> BinOp op (substituteBlockExpr lv subst e1) (substituteBlockExpr lv subst e2)
UOp op e -> UOp op (substituteBlockExpr lv subst e)
List es -> List $ map (substituteBlockExpr lv subst) es
ListAccess path i -> ListAccess (substitutePath lv subst path) i
Ctor gpi fields -> Ctor gpi $ map (substituteField lv subst) fields
Layering path1 path2 -> Layering (substitutePath lv subst path1) (substitutePath lv subst path2)
-- No substitution for literals
IntLit _ -> expr
AFloat _ -> expr
StringLit _ -> expr
BoolLit _ -> expr
-- TODO: check if this is right
PluginAccess pluginName e1 e2 -> PluginAccess pluginName (substituteBlockExpr lv subst e1) (substituteBlockExpr lv subst e2)
Tuple e1 e2 -> Tuple (substituteBlockExpr lv subst e1) (substituteBlockExpr lv subst e2)
ThenOp e1 e2 -> ThenOp (substituteBlockExpr lv subst e1) (substituteBlockExpr lv subst e2)
substituteLine :: LocalVarId -> Subst -> Stmt -> Stmt
substituteLine lv subst line =
case line of
Assign path expr -> Assign (substitutePath lv subst path) (substituteBlockExpr lv subst expr)
Override path expr -> Override (substitutePath lv subst path) (substituteBlockExpr lv subst expr)
Delete path -> Delete $ substitutePath lv subst path
-- Assumes a full substitution
substituteBlock :: (Subst, Int) -> (Block, Int) -> Block
substituteBlock (subst, substNum) (block, blockNum) = map (substituteLine (blockNum, substNum) subst) block
----- Filter with relational statements
-- Intentionally pulling out variable equality judgment (. |- x1 = x2) as string equality
varsEq :: Var -> Var -> Bool
varsEq = (==)
exprToVar :: C.Expr -> Var
exprToVar (C.VarE v) = v
exprToVar e = error $ "Style expression matching does not yet handle nested expressions: '" ++ show e ++ "'"
findType :: VarEnv -> String -> [T]
findType typeEnv name =
case M.lookup name (valConstructors typeEnv) of
Just vc -> tlsvc vc ++ [tvc vc]
Nothing -> error $ "name '" ++ name ++ "' does not exist in Substance val constructor environment"
-- shouldn't happen, since the Sub/Sty should have been statically checked)
exprsMatchArr :: VarEnv -> C.Func -> C.Func -> Bool
exprsMatchArr typeEnv subE styE =
let subArrType = findType typeEnv $ C.nameFunc subE
styArrType = findType typeEnv $ C.nameFunc styE
subVarArgs = map exprToVar $ C.argFunc subE
styVarArgs = map exprToVar $ C.argFunc styE
in let res = isSubtypeArrow subArrType styArrType typeEnv
&& (all (uncurry varsEq) $ zip subVarArgs styVarArgs) in
trM1 ("subArrType: " ++ show subArrType
++ "\nstyArrType: " ++ show styArrType
++ "\nres: " ++ show (isSubtypeArrow subArrType styArrType typeEnv)) res
-- New judgment (COMBAK number): expression matching that accounts for subtyping. G, B, . |- E0 <| E1
-- We assume the latter expression has already had a substitution applied
exprsMatch :: VarEnv -> C.Expr -> C.Expr -> Bool
-- rule Match-Expr-Var
exprsMatch typeEnv (C.VarE subVar) (C.VarE styVar) = varsEq subVar styVar
-- Match value constructor applications if one val ctor is a subtype of another
-- whereas for function applications, we match only if the exprs are equal (for now)
-- This is because a val ctor doesn't "do" anything besides wrap its values
-- whereas functions with the same type could do very different things, so we don't
-- necessarily want to match them by subtyping
-- (e.g. think of the infinite functions from Vector -> Vector)
-- rule Match-Expr-Vconsapp
exprsMatch typeEnv (C.ApplyValCons subE) (C.ApplyValCons styE) =
exprsMatchArr typeEnv subE styE
-- rule Match-Expr-Fnapp
exprsMatch typeEnv (C.ApplyFunc subE) (C.ApplyFunc styE) =
subE == styE
exprsMatch _ _ _ = False
-- Judgment 11. b; theta |- S <| |S_r
relMatchesLine :: VarEnv -> C.SubEnv -> C.SubStmt -> RelationPattern -> Bool
-- rule Bind-Match
relMatchesLine typeEnv subEnv s1@(C.Bind var expr) s2@(RelBind bvar sExpr) =
case bvar of
BStyVar v -> error ("Style variable '" ++ show v ++ "' found in relational statement '" ++ show (RelBind bvar sExpr) ++ "'. Should not be present!")
BSubVar sVar ->
let selExpr = toSubExpr sExpr in
let res = (varsEq var sVar && exprsMatch typeEnv expr selExpr)
|| C.exprsDeclaredEqual subEnv expr selExpr -- B |- E = |E
in trM1 ("trying to match exprs \n'" ++ show s1 ++ "'\n'" ++ show s2 ++ "'\n\n") $ res
-- rule Pred-Match
relMatchesLine typeEnv subEnv (C.ApplyP pred) (RelPred sPred) =
let selPred = toSubPred sPred in
C.predsEq pred selPred -- self-equal
|| C.predsDeclaredEqual subEnv pred selPred -- B |- Q <-> |Q
relMatchesLine _ _ _ _ = False -- no other line forms match each other (decl, equality, etc.)
-- Judgment 13. b |- [S] <| |S_r
relMatchesProg :: VarEnv -> C.SubEnv -> C.SubProg -> RelationPattern -> Bool
relMatchesProg typeEnv subEnv subProg rel = any (flip (relMatchesLine typeEnv subEnv) rel) subProg
-- Judgment 15. b |- [S] <| [|S_r]
allRelsMatch :: VarEnv -> C.SubEnv -> C.SubProg -> [RelationPattern] -> Bool
allRelsMatch typeEnv subEnv subProg rels = all (relMatchesProg typeEnv subEnv subProg) rels
-- Optimization to filter out Substance statements that have no hope of matching any of the substituted relation patterns, so we don't do redundant work for every substitution (of which there could be millions). This function is only called once per selector.
couldMatchRels :: VarEnv -> [RelationPattern] -> C.SubStmt -> Bool
couldMatchRels typeEnv rels stmt = any (flip couldMatchARel stmt) rels
where couldMatchARel :: RelationPattern -> C.SubStmt -> Bool
-- Heuristic: check if names are equal
couldMatchARel (RelBind _ (SEAppFunc styF _)) (C.Bind _ (C.ApplyFunc subF)) =
styF == C.nameFunc subF
couldMatchARel (RelBind _ (SEAppValCons styVC _)) (C.Bind _ (C.ApplyValCons subVC')) =
let subVC = C.nameFunc subVC' in
styVC == subVC
|| isSubtypeArrowNamed typeEnv subVC styVC -- check value ctor subtyping
couldMatchARel (RelPred styPred) (C.ApplyP subPred) =
predicateName styPred == (nameOf $ C.predicateName subPred)
couldMatchARel _ _ = False
nameOf (C.PredicateConst n) = n
isSubtypeArrowNamed :: VarEnv -> String -> String -> Bool
isSubtypeArrowNamed typeEnv subCtor styCtor =
let subArrType = findType typeEnv subCtor
styArrType = findType typeEnv styCtor
in isSubtypeArrow subArrType styArrType typeEnv
-- Judgment 17. b; [theta] |- [S] <| [|S_r] ~> [theta']
-- Folds over [theta]
filterRels :: VarEnv -> C.SubEnv -> C.SubProg -> [RelationPattern] -> [Subst] -> [Subst]
filterRels typeEnv subEnv subProg rels substs =
let subProgFiltered = filter (couldMatchRels typeEnv rels) subProg in
-- trace ("\n----------\n\nrels:\n" ++ ppShow rels
-- ++ "\nsub prog filtered\n: " ++ ppShow subProgFiltered) $
filter (\subst -> allRelsMatch typeEnv subEnv subProgFiltered
(substituteRels subst rels)) substs
----- Match declaration statements
-- Judgment 9. G; theta |- T <| |T
-- Assumes types are nullary, so doesn't return a subst, only a bool indicating whether the types matched
matchType :: VarEnv -> T -> StyT -> Bool
matchType varEnv substanceType@(TConstr tctor) styleType@(STCtor stctor) =
if not (null (argCons tctor)) || not (null (argConsS stctor))
then error "no types with parameters allowed in match" -- TODO error msg
else trM1 ("types: " ++ nameCons tctor ++ ", " ++ nameConsS stctor) $
nameCons tctor == nameConsS stctor
-- Only match if a Substance type is a subtype of a Style type (e.g. Interval matches ClosedInterval)
|| isSubtype substanceType (toSubType styleType) varEnv
-- TODO better errors + think about cases below
matchType varEnv (TTypeVar tvar) (STTypeVar stvar) = error "no type vars allowed in match"
matchType varEnv (TConstr tvar) (STTypeVar stvar) = error "no type vars allowed in match"
matchType varEnv (TTypeVar tvar) (STCtor stctor) = error "no type vars allowed in match"
-- Judgment 10. theta |- x <| B
matchBvar :: Var -> BindingForm -> Maybe Subst
matchBvar subVar (BStyVar styVar) = Just $ M.insert styVar subVar M.empty
matchBvar subVar (BSubVar styVar) = if subVar == styVar
then Just M.empty
else Nothing
-- Judgment 12. G; theta |- S <| |S_o
matchDeclLine :: VarEnv -> C.SubStmt -> DeclPattern -> Maybe Subst
matchDeclLine varEnv (C.Decl subT subVar) (PatternDecl' styT bvar) =
let typesMatched = matchType varEnv subT styT in
if typesMatched
then trM1 "types matched" $ matchBvar subVar bvar
else trM1 "types didn't match" Nothing -- substitution is only valid if types matched first
matchDeclLine _ subL styL = Nothing -- Sty decls only match Sub decls
-- Judgment 16. G; [theta] |- [S] <| [|S_o] ~> [theta']
matchDecl :: VarEnv -> C.SubProg -> [Subst] -> DeclPattern -> [Subst]
matchDecl varEnv subProg initSubsts decl =
-- Judgment 14. G; [theta] |- [S] <| |S_o
let newSubsts = map (flip (matchDeclLine varEnv) decl) subProg in
trM1 ("new substs: " ++ show newSubsts) $ merge initSubsts (catMaybes newSubsts)
-- TODO: why is this trace necessary to see the rest of the debug output?
-- is it because of list comprehensions?
-- Judgment 18. G; [theta] |- [S] <| [|S_o] ~> [theta']
-- Folds over [|S_o]
matchDecls :: VarEnv -> C.SubProg -> [DeclPattern] -> [Subst] -> [Subst]
matchDecls varEnv subProg decls initSubsts = foldl (matchDecl varEnv subProg) initSubsts decls
----- Overall judgments
find_substs_sel :: VarEnv -> C.SubEnv -> C.SubProg -> (Header, SelEnv) -> [Subst]
-- Judgment 19. g; G; b; [theta] |- [S] <| Sel
-- NOTE: this uses little gamma (not in paper) to check substitution validity
find_substs_sel varEnv subEnv subProg (Select sel, selEnv) =
let decls = selHead sel ++ selWith sel
rels = selWhere sel
initSubsts = []
rawSubsts = matchDecls varEnv subProg decls initSubsts
subst_candidates = filter (fullSubst selEnv)
$ trace ("rawSubsts: # " ++ show (length rawSubsts))
rawSubsts
-- TODO: check validity of subst_candidates (all StyVars have exactly one SubVar)
filtered_substs = trM1 ("candidates: " ++ show subst_candidates) $
filterRels varEnv subEnv subProg rels subst_candidates
correct_substs = filter uniqueKeysAndVals filtered_substs
in correct_substs
find_substs_sel _ _ _ (Namespace _, _) = [] -- No substitutions for a namespace (not in paper)
-- TODO: add note on prog, header judgment to paper?
-- Find a list of substitutions for each selector in the Sty program.
find_substs_prog :: VarEnv -> C.SubEnv -> C.SubProg -> StyProg -> [SelEnv] -> [[Subst]]
find_substs_prog varEnv subEnv subProg styProg selEnvs =
let sels = map fst styProg in
let selsWithEnvs = zip sels selEnvs in
map (find_substs_sel varEnv subEnv subProg) selsWithEnvs
-- TODO: make anonymous variables for unification for Substance program
-------------------- Translation dynamics (i.e. actual Style compiler)
-- TODO: block statics
checkBlock :: SelEnv -> Block -> [Error]
checkBlock selEnv block = []
----- Type definitions
type GPICtor = String
data TagExpr a = OptEval Expr -- ^ Thunk evaluated at each step of optimization-time
| Done (Value a) -- ^ A value in the host language, fully evaluated
| Pending (Value a) -- ^ A value to be updated afterwards (e.g. label dimensions)
deriving (Show, Eq, Typeable)
type PropertyDict a = M.Map Property (TagExpr a)
type FieldDict a = M.Map Field (FieldExpr a)
data FieldExpr a = FExpr (TagExpr a)
| FGPI ShapeTypeStr (PropertyDict a)
deriving (Show, Eq, Typeable)
type Warning = String
data Name = Sub String -- Sub obj name
| Gen String -- randomly generated name
deriving (Show, Eq, Ord, Typeable)
data Translation a = Trans { trMap :: M.Map Name (FieldDict a),
warnings :: [Warning] }
deriving (Show, Eq, Typeable)
type OverrideFlag = Bool
-- For a Substance object "A", the Translation might look like this:
-- Trans [ "A" =>
-- FieldDict [ "val" => FExpr (Done (IntLit 2)),
-- "shape" => GPI Circ PropMap [ "r" => OptEval (EPath (FieldPath (SubVar (VC "B"))) "val"),
-- "x" => ... ] ] ]
----- Translation util functions
initTrans :: forall a . Autofloat a => Translation a
initTrans = Trans { trMap = M.empty, warnings = [] }
-- Convert Sub bvar name to Sub name in Translation
trName :: BindingForm -> Name
trName (BSubVar (VarConst nm)) = Sub nm
trName (BStyVar (StyVar' nm)) = Sub nm
-- error ("Style variable '" ++ show bv ++ "' in block! Was a non-full substitution applied?") -- TODO/URGENT fix for namespaces
nameStr :: Name -> String
nameStr (Sub s) = s
nameStr (Gen s) = s
mkPropertyDict :: (Autofloat a) => [PropertyDecl] -> PropertyDict a
mkPropertyDict propertyDecls = foldl addPropertyDecl M.empty propertyDecls
where addPropertyDecl :: PropertyDict a -> PropertyDecl -> PropertyDict a
-- TODO: check that the same property is not declared twice
addPropertyDecl dict (PropertyDecl property expr) = M.insert property (OptEval expr) dict
-- All warnings are appended
addMaybe :: [a] -> Maybe a -> [a]
addMaybe xs x = xs ++ maybeToList x
addMaybes :: [a] -> [Maybe a] -> [a]
addMaybes xs ms = xs ++ catMaybes ms
addWarn :: Translation a -> Warning -> Translation a
addWarn tr warn = tr { warnings = warnings tr ++ [warn] }
-- TODO clean these up
pathStr :: Path -> String
pathStr (FieldPath bvar field) = intercalate "." [show bvar, field]
pathStr (PropertyPath bvar field property) = intercalate "." [show bvar, field, property]
pathStr2 :: Name -> Field -> String
pathStr2 name field = intercalate "." [nameStr name, field]
pathStr3 :: Name -> Field -> Property -> String
pathStr3 name field property = intercalate "." [nameStr name, field, property]
----- Main operations on translations (add and delete)
-- TODO distinguish between warns/errs
deleteField :: (Autofloat a) => Translation a -> Name -> Field -> Translation a
deleteField trans name field =
let trn = trMap trans in
case M.lookup name trn of
Nothing ->
let err = "Err: Sub obj '" ++ nameStr name ++ "' has no fields; can't delete field '" ++ field ++ "'" in
addWarn trans err
Just fieldDict ->
if field `M.notMember` fieldDict
then let warn = "Warn: Sub obj '" ++ nameStr name ++ "' already lacks field '" ++ field ++ "'" in
addWarn trans warn
else let fieldDict' = M.delete field fieldDict
trn' = M.insert name fieldDict' trn in
trans { trMap = trn' }
deleteProperty :: (Autofloat a) => Translation a -> Name -> Field -> Property -> Translation a
deleteProperty trans name field property =
let trn = trMap trans
path = pathStr3 name field property in
case M.lookup name trn of
Nothing ->
let err = "Err: Sub obj '" ++ nameStr name ++ "' has no fields; can't delete path '" ++ path ++ "'" in
addWarn trans err
Just fieldDict ->
case M.lookup field fieldDict of
Nothing -> let err = "Err: Sub obj '" ++ nameStr name ++ "' already lacks field '" ++ field
++ "'; can't delete path " ++ path in
addWarn trans err
-- Deal with path aliasing as in `addProperty`
Just (FExpr e) ->
case e of
OptEval (EPath p@(FieldPath bvar newField)) ->
let newName = trName bvar in
if newName == name && newField == field
then let err = "Error: path '" ++ pathStr p ++ "' was aliased to itself"
in addWarn trans err
else deleteProperty trans newName newField property
res -> let err = "Error: Sub obj '" ++ nameStr name ++ "' does not have GPI '"
++ field ++ "'; cannot delete property '" ++ property ++ "'" in
addWarn trans err
Just (FGPI ctor properties) ->
-- If the field is GPI, check if property already exists
if property `M.notMember` properties
then let warn = "Warning: property '" ++ property ++ "' already does not exist in path '"
++ pathStr3 name field property ++ "'; deletion does nothing"
in addWarn trans warn
else let properties' = M.delete property properties
fieldDict' = M.insert field (FGPI ctor properties') fieldDict
trn' = M.insert name fieldDict' trn in
trans { trMap = trn' }
-- Implements two rules for fields:
-- x.n = Ctor { n_i = e_i }, rule Line-Set-Ctor, for GPI
-- x.n = e, rule Line-Set-Field-Expr
addField :: (Autofloat a) => OverrideFlag -> Translation a ->
Name -> Field -> TagExpr a -> Translation a
addField override trans name field texpr =
let trn = trMap trans in
let fieldDict = case M.lookup name trn of
Nothing -> M.empty -- Initialize the field dict if it hasn't been initialized
Just fdict -> fdict in
-- Warn using override if x doesn't exist
let warn1 = if fieldDict == M.empty && override
then Just $ "Warning: Sub obj '" ++ nameStr name ++ "' has no fields, but override was declared"
else Nothing in
-- Warn using override if x.n already exists
let warn2 = if (field `M.member` fieldDict) && (not override)
then Just $ "Warning: Sub obj '" ++ nameStr name ++ "''s field '" ++ field
++ "' is overridden, but was not declared an override"
else Nothing in
-- Warn using override if x.n doesn't exist
let warn3 = if (field `M.notMember` fieldDict) && override
then Just $ "Warning: field '" ++ field ++ "' declared override, but has not been initialized"
else Nothing in
-- TODO: check existing FExpr is overridden by an FExpr and likewise for Ctor of same type (typechecking)
let fieldExpr = case texpr of
OptEval (Ctor ctorName propertyDecls) -> -- rule Line-Set-Ctor
FGPI ctorName (mkPropertyDict propertyDecls)
_ -> FExpr texpr in -- rule Line-Set-Field-Expr
let fieldDict' = M.insert field fieldExpr fieldDict
trn' = M.insert name fieldDict' trn in
trans { trMap = trn', warnings = addMaybes (warnings trans) [warn1, warn2, warn3] }
addProperty :: (Autofloat a) => OverrideFlag -> Translation a ->
Name -> Field -> Property -> TagExpr a -> Translation a
addProperty override trans name field property texpr =
let trn = trMap trans in
-- Setting a field's property should require that field to already exist and be a GPI
-- TODO: distinguish b/t errors and warns
case M.lookup name trn of
Nothing -> let err = "Error: Sub obj '" ++ nameStr name ++ "' has no fields; cannot add property" in
addWarn trans err
Just fieldDict ->
case M.lookup field fieldDict of
Nothing -> let err = "Error: Sub obj '" ++ nameStr name ++ "' does not have field '"
++ field ++ "'; cannot add property '" ++ property ++ "'" in
addWarn trans err
-- If looking up "f.domain" yields a *different* path (i.e. that path was an alias)
-- e.g. "f.domain" is aliased to "I.shape"
-- then call addProperty with the other path, otherwise fail
Just (FExpr e) ->
case e of
OptEval (EPath p@(FieldPath bvar newField)) ->
let newName = trName bvar in
if newName == name && newField == field
then let err = "Error: path '" ++ pathStr p ++ "' was aliased to itself"
in addWarn trans err
else addProperty override trans newName newField property texpr
res -> let err = "Error: Sub obj '" ++ nameStr name ++ "' does not have GPI '"
++ field ++ "'; found expr '" ++ show res ++ "'; cannot add property '" ++ property ++ "'" in
addWarn trans err
Just (FGPI ctor properties) ->
-- If the field is GPI, check if property already exists and whether it matches the override setting
let warn = if (property `M.notMember` properties) && override
then Just $ "Warning: property '" ++ property ++ "' does not exist in path '"
++ pathStr3 name field property ++ "' but override was set"
else if property `M.member` properties && (not override)
then Just $ "Warning: property '" ++ property ++ "' already exists in path '"
++ pathStr3 name field property ++ "' but override was not set"
else Nothing in
let properties' = M.insert property texpr properties
fieldDict' = M.insert field (FGPI ctor properties') fieldDict
trn' = M.insert name fieldDict' trn in
trans { trMap = trn', warnings = addMaybe (warnings trans) warn }
-- rule Line-Delete
deletePath :: (Autofloat a) => Translation a -> Path -> Either [Error] (Translation a)
deletePath trans path =
case path of
FieldPath bvar field ->
let name = trName bvar
trans' = deleteField trans name field in
Right trans'
PropertyPath bvar field property ->
let name = trName bvar
trans' = deleteProperty trans name field property in
Right trans'
addPath :: (Autofloat a) => OverrideFlag -> Translation a -> Path -> TagExpr a -> Either [Error] (Translation a)
addPath override trans path expr =
case path of
-- rule Line-Set-Field-Expr, Line-Set-Ctor
FieldPath bvar field ->
let name = trName bvar
trans' = addField override trans name field expr in
Right trans'
-- rule Line-Set-Prop-Expr
PropertyPath bvar field property ->
let name = trName bvar
trans' = addProperty override trans name field property expr in
Right trans'
----- Translation judgments
{- Note: All of the folds below use foldM.
foldM stops accumulating when the first fatal error is reached, using "Either [Error]" as a monad
(Non-fatal errors are stored as warnings in the translation)
foldM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
example:
f acc elem = if elem < 0 then Left ["wrong " ++ show elem] else Right $ elem : acc
foldM f [] [1, 9, -1, 2, -2] = Left ["wrong -1"]
foldM f [] [1, 9] = Right [9,1] -}
-- Judgment 26. D |- phi ~> D'
-- This is where interesting things actually happen (each line is interpreted and added to the translation)
translateLine :: (Autofloat a) => Translation a -> Stmt -> Either [Error] (Translation a)
translateLine trans stmt =
case stmt of
Assign path expr -> addPath False trans path (OptEval expr)
Override path expr -> addPath True trans path (OptEval expr)
Delete path -> deletePath trans path
-- Judgment 25. D |- |B ~> D' (modified to be: theta; D |- |B ~> D')
translateBlock :: (Autofloat a) => (Block, Int) -> Translation a -> (Subst, Int) ->
Either [Error] (Translation a)
translateBlock blockWithNum trans substNum =
let block' = substituteBlock substNum blockWithNum in
foldM translateLine trans block'
-- Judgment 24. [theta]; D |- |B ~> D'
translateSubstsBlock :: (Autofloat a) => Translation a -> [(Subst, Int)] ->
(Block, Int) -> Either [Error] (Translation a)
translateSubstsBlock trans substsNum blockWithNum = foldM (translateBlock blockWithNum) trans substsNum
-- Judgment 23, contd.
translatePair :: (Autofloat a) => VarEnv -> C.SubEnv -> C.SubProg ->
Translation a -> ((Header, Block), Int) -> Either [Error] (Translation a)
translatePair varEnv subEnv subProg trans ((Namespace styVar, block), blockNum) =
let selEnv = initSelEnv
bErrs = checkBlock selEnv block in
if null (sErrors selEnv) && null bErrs
then let subst = M.empty in -- is this the correct empty?
translateBlock (block, blockNum) trans (subst, 0) -- skip transSubstsBlock; only one subst
else Left $ sErrors selEnv ++ bErrs
translatePair varEnv subEnv subProg trans ((header@(Select sel), block), blockNum) =
let selEnv = checkSel varEnv sel
bErrs = checkBlock selEnv block in
if null (sErrors selEnv) && null bErrs
then let substs = find_substs_sel varEnv subEnv subProg (header, selEnv) in
let numberedSubsts = zip substs [0..] in -- For creating unique local var names
translateSubstsBlock trans numberedSubsts (block, blockNum)
else Left $ sErrors selEnv ++ bErrs
insertLabels :: (Autofloat a, Eq a) => Translation a -> C.LabelMap -> Translation a
insertLabels trans labels =
trans { trMap = M.mapWithKey insertLabel (trMap trans),
warnings = warnings trans ++ ["Note: Text GPIs are automatically deleted if their Substance object has no label"]
-- TODO: print out the names of the GPIs that were auto-deleted
}
where
toFieldStr :: Eq a => String -> FieldExpr a
toFieldStr s = FExpr $ Done $ StrV s
insertLabel :: Eq a => Name -> FieldDict a -> FieldDict a
insertLabel (Sub s) fieldDict =
let labelField = "label" in
case M.lookup s labels of
Nothing -> fieldDict
-- NOTE: maybe this is a "namespace," so we pass through
Just (Just l) -> M.insert labelField (toFieldStr l) fieldDict
-- If "NoLabel", default to an empty string *and* delete any Text GPIs that use it
Just Nothing -> let fd' = M.insert labelField (toFieldStr "") fieldDict in
M.filter (not . usesLabelText s) fd'
-- only insert labels for Substance objects
insertLabel (Gen _) fieldDict = fieldDict
-- Return True if it's a Text GPI that uses the label
-- TODO: should probably do something with other GPIs/fields that use the label (delete/filter/modify them?)
-- as well as recursively delete anything else that refers to *those* things
usesLabelText :: Eq a => String -> FieldExpr a -> Bool
usesLabelText subName (FExpr _) = False
usesLabelText subName (FGPI shapeType properties) =
let labelForm = OptEval (EPath (FieldPath (BSubVar (VarConst subName)) "label"))
usesLabel = case M.lookup "string" properties of
Nothing -> False
Just expr -> expr == labelForm
in shapeType == "Text" && usesLabel
-- For any Substance object (say one called "K1"), insert the field mapping `K1.name = "K1"` which will be accessible from Style.
-- This is generally for plugin accessors to use in Style, so they can access the right field of the Style values returned by a plugin.
insertNames :: (Autofloat a, Eq a) => Translation a -> Translation a
insertNames trans = trans { trMap = M.mapWithKey insertName $ trMap trans }
where insertName :: Name -> FieldDict a -> FieldDict a -- I guess we don't need to insert names for namespaces
insertName (Sub name) fieldDict =
let nameField = "name" in
M.insert nameField (FExpr $ Done $ StrV name) fieldDict
insertName (Gen _) fieldDict = fieldDict
{- Find plugin accessor expressions
Evaluates a plugin accessor’s subexpressions (the primary and secondary key)
Static evaluate: look up value in translation (perform compile-time computations)
Check their types (both need to be strings)
Look up the result in the plugin’s JSON output
Store it in the translation in place of the accessor, as a finished float -}
evalPluginAccess :: (Autofloat a) => StyValMap a -> Translation a -> Translation a
evalPluginAccess valMap trans =
trans { trMap = M.mapWithKey (evalFieldAccesses valMap) $ trMap trans }
where evalFieldAccesses :: (Autofloat a) => StyValMap a -> Name -> FieldDict a -> FieldDict a
evalFieldAccesses vmap (Sub name) fieldDict =
M.mapWithKey (evalFieldAccess vmap) fieldDict
evalFieldAccesses vmap (Gen _) fieldDict = fieldDict
evalFieldAccess :: (Autofloat a) => StyValMap a -> Field -> FieldExpr a -> FieldExpr a
evalFieldAccess vmap field (FExpr te) = FExpr $ evalTExpr vmap te
evalFieldAccess vmap field (FGPI stype properties) =
let properties' = M.mapWithKey (evalPropertyAccess vmap) properties in
FGPI stype properties'
evalPropertyAccess :: (Autofloat a) => StyValMap a -> Property -> TagExpr a -> TagExpr a
evalPropertyAccess vmap property te = evalTExpr vmap te
evalTExpr :: (Autofloat a) => StyValMap a -> TagExpr a -> TagExpr a
evalTExpr vmap val@(Done _) = val
evalTExpr vmap (OptEval e) = OptEval $ evalPluginExpr vmap e
-- TODO: check if the result was a string, and if so, make it a done value?
evalPluginExpr :: (Autofloat a) => StyValMap a -> Expr -> Expr
-- Do work: evaluate something like ddg[A.name]["x"] by evaluating each key and looking up the result in JSON
evalPluginExpr vmap (PluginAccess p e1 e2) =
-- TODO: actually check/use the plugin string; this currently ignores the plugin `p`
-- just use the trans in the context of `evalPluginAccess` for now, TODO: fix to pass it around?
-- or remove the vmap from the context
let e1' = evalStatic e1
e2' = evalStatic e2
res = lookupStyVal e1' e2' vmap
in AFloat $ Fix $ r2f res
-- Look for work to do (might involve strings)
evalPluginExpr vmap (CompApp s es) = CompApp s $ map (evalPluginExpr vmap) es
evalPluginExpr vmap (ObjFn s es) = ObjFn s $ map (evalPluginExpr vmap) es
evalPluginExpr vmap (ConstrFn s es) = ConstrFn s $ map (evalPluginExpr vmap) es
evalPluginExpr vmap (AvoidFn s es) = AvoidFn s $ map (evalPluginExpr vmap) es
evalPluginExpr vmap (BinOp o e1 e2) = BinOp o (evalPluginExpr vmap e1) (evalPluginExpr vmap e2)
evalPluginExpr vmap (UOp o e) = UOp o $ evalPluginExpr vmap e
evalPluginExpr vmap (List es) = List $ map (evalPluginExpr vmap) es
evalPluginExpr vmap (Tuple e1 e2) = Tuple (evalPluginExpr vmap e1) (evalPluginExpr vmap e2)
evalPluginExpr vmap (ThenOp e1 e2) = ThenOp (evalPluginExpr vmap e1) (evalPluginExpr vmap e2)
-- Leaves (no strings should be involved)
evalPluginExpr _ e@(IntLit _) = e
evalPluginExpr _ e@(AFloat _) = e
evalPluginExpr _ e@(StringLit _) = e
evalPluginExpr _ e@(BoolLit _) = e
evalPluginExpr _ e@(EPath _) = e
evalPluginExpr _ e@(ListAccess _ _) = e
evalPluginExpr _ e@(Ctor _ _) = e
evalPluginExpr _ e@(Layering _ _) = e
evalStatic :: Expr -> String
evalStatic (StringLit s) = s
evalStatic (EPath (FieldPath bvar field)) =
case lookupField bvar field trans of -- TODO: clean up lookupField location
FExpr (OptEval (StringLit s)) -> s
FExpr (Done (StrV s)) -> s
_ -> error "expected string for plugin accessor key; after looking up field, didn't get string"
evalStatic (EPath (PropertyPath (BSubVar v) field property)) = error "plugin TODO"
evalStatic e = error "expected string or path expression for plugin accessor key; did not get a string"
-- TODO: add beta in paper and to comment below
-- Judgment 23. G; D |- [P]; |P ~> D'
-- Fold over the pairs in the Sty program, then the substitutions for a selector, then the lines in a block.
translateStyProg :: forall a . (Autofloat a) =>
VarEnv -> C.SubEnv -> C.SubProg -> StyProg -> C.LabelMap -> [J.StyVal] ->
Either [Error] (Translation a)
translateStyProg varEnv subEnv subProg styProg labelMap styVals =
let numberedProg = zip styProg [0..] in -- For creating unique local var names
case foldM (translatePair varEnv subEnv subProg) initTrans numberedProg of
Right trans ->
let transWithNames = insertNames trans
transWithNamesAndLabels = insertLabels transWithNames labelMap
styValMap = styJsonToMap styVals
transWithPlugins = evalPluginAccess styValMap transWithNamesAndLabels
in trace "translateStyProg: " $ Right transWithPlugins
Left errors -> Left errors
---------- Plugin accessors
type SubObjName = String
type PropertyName = String
type StyValMap a = M.Map SubObjName (M.Map PropertyName a)
styJsonToMap :: (Autofloat a) => [J.StyVal] -> StyValMap a
styJsonToMap vals =
M.fromList (map (\v -> (subName v,
M.fromList (map (\w -> (propertyName w,
r2f $ propertyVal w))
(nameVals v))))
vals)
-- TODO move lookups to utils; this was moved from GenOptProblem
lookupField :: (Autofloat a) => BindingForm -> Field -> Translation a -> FieldExpr a
lookupField bvar field trans =
let name = trName bvar in
let trn = trMap trans in
case M.lookup name trn of
Nothing -> error ("path '" ++ pathStr2 name field ++ "''s name doesn't exist in trans")
-- TODO improve error messages and return error messages (Either [Error] (TagExpr a))
Just fieldDict ->
case M.lookup field fieldDict of
Nothing -> error ("path '" ++ pathStr2 name field ++ "'s field doesn't exist in trans")
Just fexpr -> fexpr
-- TODO: This is the right way to look up fields, but doing so causes a frontend undefined error. Why?
-- case fexpr of
-- -- Deal with field aliases, e.g. `f.codomain = R.shape`. Keep looking up paths until we get a GPI or expression.
-- FExpr (OptEval (EPath (FieldPath bvarSynonym fieldSynonym))) ->
-- if bvar == bvarSynonym && field == fieldSynonym
-- then error ("nontermination in lookupField with path '" ++ pathStr2 name field ++ "' set to itself")
-- else trace ("Recursively looking up field " ++ pathStr (FieldPath bvar field) ++ " -> " ++ pathStr (FieldPath bvarSynonym fieldSynonym)) lookupField bvarSynonym fieldSynonym trans
-- _ -> fexpr
shapeType :: (Autofloat a) => BindingForm -> Field -> Translation a -> ShapeTypeStr
shapeType bvar field trans =
case lookupField bvar field trans of
FGPI stype _ -> stype
-- -- Deal with field aliases, e.g. `f.codomain = R.shape`. Keep looking up paths until we get a GPI or expression.
FExpr (OptEval (EPath (FieldPath bvarSynonym fieldSynonym))) ->
if bvar == bvarSynonym && field == fieldSynonym
then error ("nontermination in lookupField with path '" ++ pathStr (FieldPath bvar field) ++ "' set to itself")
else {- trace ("Recursively looking up field " ++ pathStr (FieldPath bvar field) ++ " -> " ++ pathStr (FieldPath bvarSynonym fieldSynonym)) -} shapeType bvarSynonym fieldSynonym trans
FExpr e -> error ("path " ++ show e ++ " is not a GPI; cannot get type")
lookupStyVal :: (Autofloat a) => String -> String -> StyValMap a -> a
lookupStyVal subName propName vmap =
case M.lookup subName vmap of
Nothing -> error ("plugin accessors in style: for access " ++ toAccess subName propName ++ ", primary key does not exist")
Just propDict ->
case M.lookup propName propDict of
Nothing -> error ("plugin accessors in style: for access " ++ toAccess subName propName ++ ", property does not exist")
Just val -> val
where toAccess s1 s2 = s1 ++ "." ++ s2
--------------------------------------------------------------------------------
-- Debugging
-- main :: IO ()
-- main = do
-- let f = "sty/test.sty"
--
-- let elementFile = "real-analysis-domain/real-analysis.dsl"
-- elementIn <- readFile elementFile
-- elementEnv <- parseElement elementFile elementIn
--
-- prog <- readFile f
-- res <- parseInstantiation f prog elementEnv
-- print res