Skip to content

Commit

Permalink
showExpr and linearize now refresh the printed variables if needed
Browse files Browse the repository at this point in the history
  • Loading branch information
aarneranta committed Mar 1, 2024
1 parent c218227 commit 7e70750
Show file tree
Hide file tree
Showing 2 changed files with 15 additions and 4 deletions.
17 changes: 14 additions & 3 deletions src/runtime/haskell/PGF/Expr.hs
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,8 @@ module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..
MetaId,

-- helpers
pMeta,pArg,pLit,freshName,ppMeta,ppLit,ppParens
pMeta,pArg,pLit,freshName,ppMeta,ppLit,ppParens,
freshBoundVars
) where

import PGF.CId
Expand Down Expand Up @@ -235,10 +236,11 @@ pLit = liftM LStr (RP.readS_to_P reads)

ppExpr :: Int -> [CId] -> Expr -> PP.Doc
ppExpr d scope (EAbs b x e) = let (bs,xs,e1) = getVars [] [] (EAbs b x e)
xs' = freshBoundVars scope xs
in ppParens (d > 1) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (reverse (List.zipWith ppBind bs xs))) PP.<+>
PP.hsep (PP.punctuate PP.comma (reverse (List.zipWith ppBind bs xs'))) PP.<+>
PP.text "->" PP.<+>
ppExpr 1 (xs++scope) e1)
ppExpr 1 (xs' ++ scope) e1)
where
getVars bs xs (EAbs b x e) = getVars (b:bs) ((freshName x xs):xs) e
getVars bs xs e = (bs,xs,e)
Expand Down Expand Up @@ -289,6 +291,15 @@ freshName x xs0 = loop 1 x
| elem y xs = loop (i+1) (mkCId (show x++show i))
| otherwise = y

-- refresh new vars xs in scope if needed. AR 2024-03-01
freshBoundVars :: [CId] -> [CId] -> [CId]
freshBoundVars scope xs = foldr fresh [] xs
where
fresh x xs' = mkCId (freshName (showCId x) xs') : xs'
freshName s xs' =
if elem (mkCId s) (xs' ++ scope)
then freshName (s ++ "'") xs'
else s

-----------------------------------------------------
-- Computation
Expand Down
2 changes: 1 addition & 1 deletion src/runtime/haskell/PGF/Linearize.hs
Original file line number Diff line number Diff line change
Expand Up @@ -81,7 +81,7 @@ linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e []))
where
lp = lproductions cnc

lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (x:xs) e es
lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (freshBoundVars (xs ++ ys) [x] ++ xs) e es --fresh: AR 2024
lin mb_cty n_fid e0 ys xs (EApp e1 e2) es = lin mb_cty n_fid e0 ys xs e1 (e2:es)
lin mb_cty n_fid e0 ys xs (EImplArg e) es = lin mb_cty n_fid e0 ys xs e es
lin mb_cty n_fid e0 ys xs (ETyped e _) es = lin mb_cty n_fid e0 ys xs e es
Expand Down

0 comments on commit 7e70750

Please sign in to comment.