fp-il

My bachelor project (unfinished)
Log | Files | Refs

Lift.hs (4878B)

      1 module Lift where
      2 
      3 import Data.Functor.Foldable
      4 import Data.List
      5 import Types
      6 
      7 converge f a = let a' = f a in if a' == a then a else converge f a'
      8 
      9 factorial :: AExp
     10 factorial =
     11     ( Lam
     12         ["n"]
     13         ( Let
     14             "m"
     15             (Call "factorial" [(ASub (Ident "n") (Number 1))])
     16             ( If
     17                 (ALt (Ident "n") (Number 2))
     18                 (FC (Atom (Number 1)))
     19                 (FC (Atom (AMul (Ident "m") (Ident "n"))))
     20             )
     21         )
     22     )
     23 
     24 three :: CExp
     25 three =
     26     ( Let
     27         "n"
     28         (Atom (Number 1))
     29         ( Let
     30             "n"
     31             (Atom (AAdd (Ident "n") (Number 1)))
     32             ( Let
     33                 "n"
     34                 (Atom (AAdd (Ident "n") (Number 1)))
     35                 (FC (Atom (Ident "n")))
     36             )
     37         )
     38     )
     39 
     40 liftArgs :: AExp -> AExp
     41 liftArgs lam@(Lam args body) = Lam (args ++ cata findVarsAExp lam) body
     42 liftArgs rest = rest
     43 
     44 -- | F-Algebras to find free variables
     45 findVars :: CExpF [String] -> [String]
     46 findVars (LetF ident fc rest) = converge (\\ [ident]) $ rest ++ (findVarsFC fc)
     47 findVars (IfF cond t e) = t ++ e ++ (cata findVarsAExp cond)
     48 findVars (FCF fc) = findVarsFC fc
     49 
     50 findVarsFC :: Funcall -> [String]
     51 findVarsFC (Atom aexp) = cata findVarsAExp aexp
     52 findVarsFC (Call id args) = id : (args >>= cata findVarsAExp)
     53 
     54 findVarsAExp :: AExpF [String] -> [String]
     55 findVarsAExp (IdentF ns) = [ns]
     56 findVarsAExp (LamF args cexp) = converge (\\ args) (fold findVars cexp)
     57 findVarsAExp def = foldMap id def
     58 
     59 -- replacing free variables with a new one if it matches the argument
     60 
     61 compareNames n m = if n == m then n ++ "_" else n
     62 
     63 -- | replace bound variables in AExps
     64 
     65 -- >>> hoist (replaceVarsAExp "n") factorial
     66 replaceVarsAExp :: String -> AExpF a -> AExpF a
     67 replaceVarsAExp n (IdentF m) = IdentF $ compareNames m n
     68 replaceVarsAExp n (LamF args body) =
     69     LamF
     70         (fmap (\x -> if x == n then x ++ "_" else x) args)
     71         (cata replaceVarsCExp body n)
     72 replaceVarsAExp _ rest = rest
     73 
     74 -- | replace bound variables in CExps
     75 replaceVarsCExp :: CExpF (String -> CExp) -> String -> CExp
     76 replaceVarsCExp (LetF name fc restf) = do
     77     env <- id
     78     rest <- restf
     79     let newName = compareNames name env
     80     return $ Let newName (replaceVarsFC env fc) rest
     81 replaceVarsCExp (IfF cond thenF elseF) = do
     82     thenPart <- thenF
     83     elsePart <- elseF
     84     env <- id
     85     return $ If (hoist (replaceVarsAExp env) cond) thenPart elsePart
     86 replaceVarsCExp (FCF fc) = do
     87     env <- id
     88     return $ FC (replaceVarsFC env fc)
     89 
     90 -- | replace bound variables in Function calls
     91 replaceVarsFC :: String -> Funcall -> Funcall
     92 replaceVarsFC n (Atom aexp) = Atom $ hoist (replaceVarsAExp n) aexp
     93 replaceVarsFC n (Call name args) =
     94     Call
     95         (compareNames name n)
     96         $ fmap (hoist (replaceVarsAExp n)) args
     97 
     98 subVarsAExp :: ([String], AExpF a) -> AExpF ([String], a)
     99 subVarsAExp (env, LamF args body) =
    100     let
    101         toReplace = intersect env args
    102         newArgs = fmap (\x -> if x `elem` toReplace then x ++ "_" else x) args
    103         newBody = foldl (cata replaceVarsCExp) body toReplace
    104      in
    105         LamF newArgs (cotransverse subVarsCExp (newArgs ++ env, [], newBody))
    106 subVarsAExp (env, rest) = fmap (env,) rest
    107 
    108 {- | cotransverse of a complex expression. The first string list represents
    109 | bound variables, the second one a queue of variables to be replaced
    110 -}
    111 subVarsCExp :: ([String], [String], CExpF a) -> CExpF ([String], [String], a)
    112 subVarsCExp (env, queue, LetF name fc rest) =
    113     let
    114         (newName, oldNames) =
    115             foldr
    116                 (\m (n, ns) -> if n == m then (n ++ "_", n : ns) else (n, ns)) -- repeatedly replace variables in the function call
    117                 (name, [])
    118                 queue -- make sure to do oldest first!
    119         newFC = foldr replaceVarsFC fc $ oldNames \\ [newName]
    120      in
    121         LetF newName newFC (if name `elem` env then (env, newName : queue, rest) else (name : env, name : queue, rest))
    122 subVarsCExp (env, queue, IfF cond thenPart elsePart) =
    123     IfF
    124         (foldr (\x c -> hoist (replaceVarsAExp x) c) cond queue)
    125         (env, queue, thenPart)
    126         (env, queue, elsePart)
    127 subVarsCExp (env, queue, FCF fc) = FCF $ foldr replaceVarsFC fc queue
    128 
    129 unsafeCotransverse ::
    130     (Corecursive t, Recursive a, Functor f) =>
    131     (f (Base a a) -> Base t (f a)) ->
    132     f a ->
    133     t
    134 unsafeCotransverse n = ana (n . fmap project)
    135 
    136 subVarsCExp' :: ([String], CExpF CExp) -> CExpF ([String], CExp)
    137 subVarsCExp' (env, LetF name fc body)
    138     | name `elem` env =
    139         let
    140             newName = name ++ "_"
    141             newFC = replaceVarsFC newName fc
    142             newBody = cata replaceVarsCExp body name
    143          in
    144             LetF newName newFC (newName : env, newBody)
    145     | otherwise = LetF name fc (name : env, body)
    146 subVarsCExp' (env, rest) = fmap (env,) rest
    147 
    148 substitute :: CExp -> CExp
    149 substitute = unsafeCotransverse subVarsCExp' . ([],)