forked from GitHub/gf-core
the automatically generated printnames were just junks. Now we store printnames only if they are explicitly specified.
This commit is contained in:
@@ -73,7 +73,7 @@ evalInfo opts ms m c info = do
|
|||||||
return (Just (L loc (factor param c 0 de)))
|
return (Just (L loc (factor param c 0 de)))
|
||||||
_ -> return pde -- indirection
|
_ -> return pde -- indirection
|
||||||
|
|
||||||
ppr' <- liftM Just $ evalPrintname gr c ppr (Just (L (0,0) (K $ showIdent c)))
|
ppr' <- evalPrintname gr ppr
|
||||||
|
|
||||||
return (CncCat ptyp pde' ppr')
|
return (CncCat ptyp pde' ppr')
|
||||||
|
|
||||||
@@ -83,7 +83,7 @@ evalInfo opts ms m c info = do
|
|||||||
Just (L loc de) -> do de <- partEval opts gr (cont,val) de
|
Just (L loc de) -> do de <- partEval opts gr (cont,val) de
|
||||||
return (Just (L loc (factor param c 0 de)))
|
return (Just (L loc (factor param c 0 de)))
|
||||||
Nothing -> return pde
|
Nothing -> return pde
|
||||||
ppr' <- liftM Just $ evalPrintname gr c ppr pde'
|
ppr' <- evalPrintname gr ppr
|
||||||
return $ CncFun mt pde' ppr' -- only cat in type actually needed
|
return $ CncFun mt pde' ppr' -- only cat in type actually needed
|
||||||
|
|
||||||
ResOper pty pde
|
ResOper pty pde
|
||||||
@@ -157,40 +157,12 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
|
|||||||
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
|
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
|
||||||
_ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
|
_ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
|
||||||
|
|
||||||
-- | Form the printname: if given, compute. If not, use the computed
|
evalPrintname :: SourceGrammar -> Maybe (L Term) -> Err (Maybe (L Term))
|
||||||
-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
|
evalPrintname gr mpr =
|
||||||
--- We cannot use linearization at this stage, since we do not know the
|
case mpr of
|
||||||
--- defaults we would need for question marks - and we're not yet in canon.
|
Just (L loc pr) -> do pr <- computeConcrete gr pr
|
||||||
evalPrintname :: SourceGrammar -> Ident -> Maybe (L Term) -> Maybe (L Term) -> Err (L Term)
|
return (Just (L loc pr))
|
||||||
evalPrintname gr c ppr lin =
|
Nothing -> return Nothing
|
||||||
case ppr of
|
|
||||||
Just (L loc pr) -> do pr <- comp pr
|
|
||||||
return (L loc pr)
|
|
||||||
Nothing -> case lin of
|
|
||||||
Just (L loc t) -> return $ L loc (K $ clean $ render (ppTerm Unqualified 0 (oneBranch t)))
|
|
||||||
Nothing -> return $ L (0,0) (K $ showIdent c) ----
|
|
||||||
where
|
|
||||||
comp = computeConcrete gr
|
|
||||||
|
|
||||||
oneBranch t = case t of
|
|
||||||
Abs _ _ b -> oneBranch b
|
|
||||||
R (r:_) -> oneBranch $ snd $ snd r
|
|
||||||
T _ (c:_) -> oneBranch $ snd c
|
|
||||||
V _ (c:_) -> oneBranch c
|
|
||||||
FV (t:_) -> oneBranch t
|
|
||||||
C x y -> C (oneBranch x) (oneBranch y)
|
|
||||||
S x _ -> oneBranch x
|
|
||||||
P x _ -> oneBranch x
|
|
||||||
Alts d _ -> oneBranch d
|
|
||||||
_ -> t
|
|
||||||
|
|
||||||
--- very unclean cleaner
|
|
||||||
clean s = case s of
|
|
||||||
'+':'+':' ':cs -> clean cs
|
|
||||||
'"':cs -> clean cs
|
|
||||||
c:cs -> c: clean cs
|
|
||||||
_ -> s
|
|
||||||
|
|
||||||
|
|
||||||
-- do even more: factor parametric branches
|
-- do even more: factor parametric branches
|
||||||
|
|
||||||
|
|||||||
@@ -115,7 +115,7 @@ contextLength ty = case ty of
|
|||||||
|
|
||||||
-- | Show the printname of function or category
|
-- | Show the printname of function or category
|
||||||
showPrintName :: PGF -> Language -> CId -> String
|
showPrintName :: PGF -> Language -> CId -> String
|
||||||
showPrintName pgf lang id = lookMap "?" id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
|
showPrintName pgf lang id = lookMap (showCId id) id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
|
||||||
|
|
||||||
term0 :: CId -> Term
|
term0 :: CId -> Term
|
||||||
term0 = TM . showCId
|
term0 = TM . showCId
|
||||||
|
|||||||
Reference in New Issue
Block a user