git @ Cat's Eye Technologies Lanthorn / master src / Language / Lanthorn / LetRec.hs
master

Tree @master (Download .tar.gz)

LetRec.hs @master — raw · history · blame 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
module Language.Lanthorn.LetRec where

import Language.Lanthorn.AST


convert (Fun formals body) = Fun formals (convert body)
convert (Apply name args) = Apply name (map (convert) args)
convert (LetRec bindings body) = convertToLetStar (convertBindings bindings) (convert body)
convert (If c t f) = If (convert c) (convert t) (convert f)
convert (LetStar bindings body) = LetStar (convertBindings bindings) (convert body)
convert other = other

convertBindings :: [(String, Expr)] -> [(String, Expr)]
convertBindings [] = []
convertBindings ((name, expr):rest) = ((name, (convert expr)):(convertBindings rest))

convertToLetStar :: [(String, Expr)] -> Expr -> Expr
convertToLetStar bindings body =
    let
        -- For each binding, we need to send down the relevant parts of all
        -- the bindings in the letrec, so it can compose the recursive call.
        -- The relevant parts are the *name* of each binding and its *formals*.
        -- We call such a pair an "injected", for no terribly good reason
        -- (possibly because it is "injected" into every binding in the letrec).
        getInjected (name, (Fun formals body)) = (name, formals)
        injecteds = map (getInjected) bindings
        enrichedBindings = createEnrichedBindings bindings injecteds
        wrapperBindings = createWrapperBindings bindings injecteds
    in
        LetStar (enrichedBindings ++ wrapperBindings) body

wrapperNameOuter name = name ++ "$0"
wrapperNameInner name = name ++ "$1"

createEnrichedBindings [] injecteds = []
createEnrichedBindings (binding@(name, (Fun formals body)):rest) injecteds =
    let
        name' = wrapperNameOuter name
        injectedNames = map (fst) injecteds
        formals' = formals ++ (map (wrapperNameInner) injectedNames)
        body' = (LetStar (createLocalBindings injecteds injectedNames) body)
        expr' = (Fun formals' body')
        binding = (name', expr')
    in
        (binding:createEnrichedBindings rest injecteds)
createEnrichedBindings (binding:rest) injecteds =
    (binding:createEnrichedBindings rest injecteds)

createLocalBindings [] _ = []
createLocalBindings (injected@(injectedName, formals):injecteds) allInjectedNames =
    let
        formals' = map (wrapperNameInner) formals
        actuals = map (ValueOf) (formals' ++ (map (wrapperNameInner) allInjectedNames))
        binding = (injectedName, Fun formals' (Apply (wrapperNameInner injectedName) actuals))
    in
        (binding:createLocalBindings injecteds allInjectedNames)

createWrapperBindings [] injecteds = []
createWrapperBindings ((name, (Fun formals body)):rest) injecteds =
    let
        name' = name
        actuals = map (ValueOf) (formals ++ (map (\x -> wrapperNameOuter $ fst x) injecteds))
        expr' = Fun formals (Apply (wrapperNameOuter name) actuals)
        binding = (name', expr')
    in
        (binding:createWrapperBindings rest injecteds)
createWrapperBindings (binding:rest) injecteds =
    createWrapperBindings rest injecteds