Fix letrec partially

This commit is contained in:
Kirill Andreev 2020-07-28 20:51:32 +04:00
parent 6bd5d9ef84
commit 9f29dab195
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
3 changed files with 35 additions and 7 deletions

View File

@ -5,6 +5,6 @@
function foobar (const i : int) : int is function foobar (const i : int) : int is
block { block {
const j : int = 3; const j : int = 3;
const k : int = 4; const k : int = j;
function add (const l : int) : int is i+j+k+l const l : int = l;
} with add (42) } with add (42)

View File

@ -15,6 +15,7 @@ module AST.Scope
import Control.Arrow (first, second) import Control.Arrow (first, second)
import Control.Monad.State import Control.Monad.State
import Control.Monad.Identity
import qualified Data.List as List import qualified Data.List as List
import Data.Map (Map) import Data.Map (Map)
@ -91,8 +92,9 @@ ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True
ofCategory _ _ = False ofCategory _ _ = False
instance Modifies (Product '[[ScopedDecl], Maybe Category, [Text], Range, a]) where instance Modifies (Product '[[ScopedDecl], Maybe Category, [Text], Range, a]) where
ascribe (ds :> _) d = ascribe (ds :> _ :> _ :> r :> _) d =
color 2 (fsep (map (pp . _sdName) ds)) color 3 (fsep (map (pp . _sdName) ds))
$$ pp r
$$ d $$ d
addLocalScopes addLocalScopes
@ -102,8 +104,34 @@ addLocalScopes
addLocalScopes tree = addLocalScopes tree =
fmap (\xs -> fullEnvAt envWithREfs (getRange xs) :> xs) tree1 fmap (\xs -> fullEnvAt envWithREfs (getRange xs) :> xs) tree1
where where
tree1 = addNameCategories tree tree0 = runIdentity $ unLetRec tree
envWithREfs = getEnvTree tree tree1 = addNameCategories tree0
envWithREfs = getEnvTree tree0
unLetRec
:: forall xs m
. ( Monad m
, Contains Range xs
, Eq (Product xs)
)
=> LIGO (Product xs)
-> m (LIGO (Product xs))
unLetRec = descent leaveBe
[ Descent
[ \case
(r, Let (layer -> Just (Seq xs)) b) -> return $ convert (getElem r) b xs
_ -> return Nothing
]
]
where
convert :: Range -> LIGO (Product xs) -> [LIGO (Product xs)] -> Maybe (Product xs, Expr (LIGO (Product xs)))
convert r b = match @Expr . linearize r b
linearize :: Range -> LIGO (Product xs) -> [LIGO (Product xs)] -> LIGO (Product xs)
linearize r b [x] = make (modElem @Range (delta r) $ extract x, Let x b)
linearize r b (x : xs) = make (modElem @Range (delta r) $ extract x, Let x (linearize r b xs))
delta (Range _ f _) (Range s _ t) = Range s f t
addNameCategories addNameCategories
:: (Contains Range xs, Eq (Product xs)) :: (Contains Range xs, Eq (Product xs))

View File

@ -288,7 +288,7 @@ instance Pretty1 Variant where
instance Pretty1 Expr where instance Pretty1 Expr where
pp1 = \case pp1 = \case
Let decl body -> decl `above` "with" `indent` body Let decl body -> "let" <+> decl `above` body
Apply f xs -> f <+> xs Apply f xs -> f <+> xs
Constant constant -> constant Constant constant -> constant
Ident qname -> qname Ident qname -> qname