Fix letrec partially
This commit is contained in:
parent
6bd5d9ef84
commit
9f29dab195
@ -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)
|
||||||
|
@ -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))
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user