home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 2 / DATAFILE_PDCD2.iso / utilities / _gofer / !Gofer / archives / Demos / Modular / Demo next >
Encoding:
Text File  |  1993-02-12  |  5.3 KB  |  157 lines
  1. ------------------------------------------------------------------------------
  2. --The files in this directory are based on the programs described in:
  3. --
  4. --    A Modular fully-lazy lambda lifter in Haskell
  5. --    Simon L. Peyton Jones and David Lester
  6. --    Software -- Practice and Experience
  7. --    Vol 21(5), pp.479-506
  8. --    MAY 1991
  9. --
  10. --See the Readme file for more details.
  11. ------------------------------------------------------------------------------
  12.  
  13. -- Instance of Text for printing expressions:
  14.  
  15. instance Text Constant where
  16.     showsPrec p (CNum n)  = shows n
  17.     showsPrec p (CFun n)  = showString n
  18.  
  19. instance Text (Expr [Char]) where
  20.     showsPrec p (EConst k)  = shows k
  21.     showsPrec p (EVar v)    = showString v
  22.  
  23.     showsPrec p e@(EAp _ _) = showChar '(' . showsAp e . showChar ')'
  24.                               where showsAp (EAp l r) = showsAp l
  25.                                                           . showChar ' '
  26.                                                           . shows r
  27.                                     showsAp e         = shows e
  28.  
  29.     showsPrec p (ELet isRec defns body)
  30.                             = showString (if isRec then "letrec" else "let")
  31.                                 . showChar ' '
  32.                                 . showsDefns defns
  33.                                 . showString " in "
  34.                                 . shows body
  35.  
  36.     showsPrec p (ELam binders body)
  37.                             = showString "(\\"
  38.                                 . foldr1 (\h t-> h . showChar ' ' . t)
  39.                                          (map showString binders)
  40.                                 . showChar '.'
  41.                                 . shows body
  42.                                 . showChar ')'
  43.  
  44. showWithSep          :: Text a => String -> [a] -> ShowS
  45. showWithSep s [x]     = shows x
  46. showWithSep s (x:xs)  = shows x . showString s . showWithSep s xs
  47.  
  48. showsDefns           :: [Defn Name] -> ShowS
  49. showsDefns []         = showString "{}"
  50. showsDefns [d]        = showsDefn d
  51. showsDefns defns      = showChar '{'
  52.                            . foldr1 (\h t-> h . showString "; " . t)
  53.                                     (map showsDefn defns)
  54.                            . showChar '}'
  55.  
  56. showsDefn            :: Defn Name -> ShowS
  57. showsDefn (x,e)       = showString x . showString " = " . shows e
  58.  
  59. -- display lists of supercombinators:
  60.  
  61. showSCs :: [SCDefn] -> String
  62. showSCs  = layn . map showSc
  63.  where showSc (name,args,body)
  64.            = foldr1 (\n ns -> n ++ " " ++ ns) (name:args)
  65.                 ++ " = "
  66.                 ++ show body
  67.  
  68. -- Parser for input of expressions: (sorry, this is rather a hack!)
  69.  
  70. number   :: Parser Int
  71. number    = sp (many1 (sat isDigit) `do` strToNum)
  72.             where strToNum = foldl (\n d->10*n+d) 0 . map (\c->ord c - ord '0')
  73.  
  74. variable :: Parser String
  75. variable  = sp (sat isLower `seq` many (sat isAlpha) `do` (\(c,cs) -> c:cs))
  76.  
  77. constant :: Parser String
  78. constant  = sp (sat isUpper `seq` many (sat isAlpha) `do` (\(c,cs) -> c:cs))
  79.  
  80. expr     :: Parser Expression
  81. expr      = sptok "letrec" `seq` variable `seq` sptok "=" `seq` expr
  82.                          `seq` sptok "in" `seq` expr
  83.               `do` (\(lt,(v,(eq,(def,(inn,rhs)))))-> ELet True [(v,def)] rhs)
  84.                 `orelse`
  85.             sptok "let" `seq` variable `seq` sptok "=" `seq` expr
  86.                          `seq` sptok "in" `seq` expr
  87.               `do` (\(lt,(v,(eq,(def,(inn,rhs)))))-> ELet False [(v,def)] rhs)
  88.                 `orelse`
  89.             sptok "\\" `seq` listOf variable (sp (okay ())) `seq` sptok "."
  90.                        `seq` expr
  91.               `do` (\(l,(vs,(dot,e))) -> ELam vs e)
  92.                 `orelse`
  93.             atomic
  94.  
  95. atomic  :: Parser Expression
  96. atomic   = sptok "(" `seq` many1 expr `seq` sptok ")"
  97.                   `do` (\(o,(e,c))->foldl1 EAp e) 
  98.                `orelse` 
  99.            variable `do` EVar
  100.                `orelse`
  101.            constant `do` (EConst . CFun)
  102.                `orelse`
  103.            number `do` (EConst . CNum)
  104.  
  105.  
  106. inp     :: String -> Expression
  107. inp s    = case expr s of ((p,""):_) -> p
  108.                           _          -> error "Cannot parse input"
  109.  
  110. -- Examples:
  111.  
  112. ll, fll  :: Expression -> String
  113. ll        = showSCs . lambdaLift 
  114. fll       = showSCs . fullyLazyLift
  115.  
  116. example1 :: Expression
  117. example1  = inp "let f = \\x. let g = \\y.(Plus (Times x x) y) in \
  118.                              \(Plus (g 3) (g 4)) \
  119.                 \in (f 6)"
  120.  
  121. {- Results:
  122.  
  123.    ? ll example1                -- normal lambda lifting
  124.       1) $main = let f = SC1 in (f 6)
  125.       2) SC1 x = let g = (SC0 x) in (Plus (g 3) (g 4))
  126.       3) SC0 x y = (Plus (Times x x) y)
  127.  
  128.    ? fll example1                -- fully lazy version
  129.  
  130.       1) $main = let f0 = SC1 in (f0 6)
  131.       2) SC1 x1 = let v4 = (Plus (Times x1 x1)) in
  132.                   let g2 = (SC0 v4) in (Plus (g2 3) (g2 4))
  133.       3) SC0 v4 y3 = (v4 y3)
  134.  
  135. -}
  136.  
  137. example2 :: Expression
  138. example2  = inp "let \
  139.                 \   f = \\x. letrec g = \\y. (Cons (Times x x) (g y)) \
  140.                 \            in (g 3) \
  141.                 \in (f 6)"
  142.  
  143. {- Results:
  144.  
  145.    ? ll example2                -- normal lambda lifting
  146.       1) $main = let f = SC1 in (f 6)
  147.       2) SC1 x = letrec g = (SC0 g x) in (g 3)
  148.       3) SC0 g x y = (Cons (Times x x) (g y))
  149.  
  150.    ? fll example2                -- fully lazy version
  151.       1) $main = let f0 = SC1 in (f0 6)
  152.       2) SC1 x1 = let v4 = (Cons (Times x1 x1)) in
  153.                   letrec g2 = (SC0 g2 v4) in (g2 3)
  154.       3) SC0 g2 v4 y3 = (v4 (g2 y3))
  155.  
  156. -}
  157.