@@ -13,127 +13,115 @@
1313{-# LANGUAGE PatternGuards #-}
1414
1515module Language.PureScript.CodeGen.Cpp.Recursion
16− ( convertRecursiveRefs
16+ ( convertRecursiveLets
1717 ) where
1818
1919import Prelude.Compat
2020import Data.List
2121import Data.Maybe (fromJust)
22+import Data.Monoid ((<>))
2223import Data.Text (Text)
2324
2425import Language.PureScript.CodeGen.Cpp.AST as AST
2526import Language.PureScript.CodeGen.Cpp.File
2627import Language.PureScript.CodeGen.Cpp.Types
2728import Language.PureScript.Comments (Comment(..))
29+import qualified Language.PureScript.Pretty.Cpp as P
2830
2931-------------------------------------------------------------------------------------------------
30−convertRecursiveRefs :: Cpp -> Cpp
32+convertRecursiveLets :: Cpp -> Cpp
3133-------------------------------------------------------------------------------------------------
32−convertRecursiveRefs = everywhereOnCpp go
34+convertRecursiveLets = everywhereOnCpp go
3335 where
3436 go :: Cpp -> Cpp
3537 go (CppFunction name args rty qs (CppBlock cpps)) =
36− CppFunction name args rty qs (CppBlock (convertRecursive cpps))
38+ CppFunction name args rty qs (CppBlock (convertIfRecursive cpps))
3739 go (CppLambda cs args rty (CppBlock cpps)) =
38− CppLambda cs args rty (CppBlock (convertRecursive cpps))
40+ CppLambda cs args rty (CppBlock (convertIfRecursive cpps))
3941 go cpp = cpp
40− convertRecursive :: [Cpp] -> [Cpp]
41− convertRecursive cpps
42− | hasRecursion cpps
43− = convertRecursiveRefs' cpps
42+ convertIfRecursive :: [Cpp] -> [Cpp]
43+ convertIfRecursive cpps
44+ | names@(_:_) <- recNames cpps = convertRecursive names cpps
4445 where
45− hasRecursion :: [Cpp] -> Bool
46− hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'
46+ recNames :: [Cpp] -> [Text]
47+ recNames cpps' = nub $ concatMap (everythingOnCpp (++) recRefs) cpps'
4748 where
48− valnames :: [Text]
49− valnames = concatMap (everythingOnCpp (++) valname) cpps'
50− valname :: Cpp -> [Text]
51− valname (CppFunction name' _ _ _ _) = [name']
52− valname (CppVariableIntroduction (name', _) _ _) = [name']
53− valname _ = []
54− hasRecursiveRef :: Cpp -> Bool
55− hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body
56− hasRecursiveRef (CppVariableIntroduction _ _ (Just value)) = everythingOnCpp (||) ref value
57− hasRecursiveRef _ = False
58− ref :: Cpp -> Bool
59− ref (CppVar name')
60− | name' `elem` valnames = True
61− ref _ = False
62− convertRecursive cpp = cpp
49+ recRefs :: Cpp -> [Text]
50+ recRefs (CppVariableIntroduction _ qs (Just cpp))
51+ | Recursive `elem` qs = everythingOnCpp (++) recRef cpp
52+ recRefs _ = []
53+ --
54+ recRef :: Cpp -> [Text]
55+ recRef (CppVar name') | name' `elem` possiblyRecNames = [name']
56+ recRef _ = []
57+ --
58+ possiblyRecNames :: [Text]
59+ possiblyRecNames = concatMap (everythingOnCpp (++) possiblyRecName) cpps'
60+ where
61+ possiblyRecName :: Cpp -> [Text]
62+ possiblyRecName (CppVariableIntroduction (name', _) qs (Just _))
63+ | Recursive `elem` qs = [name']
64+ possiblyRecName _ = []
65+ convertIfRecursive cpp = cpp
6366
6467-------------------------------------------------------------------------------------------------
65−convertRecursiveRefs' :: [Cpp] -> [Cpp]
68+convertRecursive :: [Text] -> [Cpp] -> [Cpp]
6669-------------------------------------------------------------------------------------------------
67−convertRecursiveRefs' cpps
68− | not $ null fns = dict : (accessor topdict <$> filteredFns allCpps) ++ cpps'
70+convertRecursive names cpps
71+ | not $ null lets
72+ = defines ++
73+ [letTable] ++
74+ (everywhereOnCpp remRecLet <$> cpps) ++
75+ undefines
6976 where
70− cpps' = everywhereOnCpp removeRec <$> cpps
71− allCpps = CppBlock cpps'
72− fns :: [(Text, Cpp)]
73− fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps
74− filteredFns :: Cpp -> [(Text, Cpp)]
75− filteredFns cpp = filter (\(f, _) -> everythingOnCpp (||) (== CppVar f) cpp) fns
76− recursive :: Cpp -> [Cpp]
77− recursive cpp'@(CppFunction _ _ _ qs _)
78− | Recursive `elem` qs = [cpp']
79− recursive cpp'@(CppVariableIntroduction _ qs _)
80− | Recursive `elem` qs = [cpp']
81− recursive _ = []
82− removeRec :: Cpp -> Cpp
83− removeRec (CppFunction _ _ _ qs _)
84− | Recursive `elem` qs = CppNoOp
85− removeRec (CppVariableIntroduction _ qs _)
86− | Recursive `elem` qs = CppNoOp
87− removeRec cpp' = cpp'
88− replaceVar :: [(Text, Cpp)] -> Cpp -> Cpp
89− replaceVar rs = go
90− where
91− go (CppVar var)
92− | Just var' <- lookup var rs = var'
93− go cpp' = cpp'
94− dict :: Cpp
95− dict =
77+ tableName :: Text
78+ tableName = "let"
79+ --
80+ letTable :: Cpp
81+ letTable =
9682 CppVariableIntroduction
97− (topdict, Just $ Any [Const])
83+ (tableName, Just $ Any [Const])
9884 []
99− (Just $ CppDataLiteral ((\(f, cpp) -> CppComment [LineComment f] cpp) <$> fns))
100− accessed :: Text -> Text -> (Text, Cpp)
101− accessed dictname name =
85+ (Just $ CppDataLiteral ((\(f, cpp) -> CppComment [LineComment f] cpp) <$> lets))
86+ --
87+ lets :: [(Text, Cpp)]
88+ lets = tableItem <$> concatMap (everythingOnCpp (++) recLet) cpps
89+ --
90+ recLet :: Cpp -> [Cpp]
91+ recLet cpp@(CppVariableIntroduction (name, _) _ (Just _))
92+ | name `elem` names = [cpp]
93+ recLet _ = []
94+ --
95+ remRecLet :: Cpp -> Cpp
96+ remRecLet (CppVariableIntroduction (name, _) _ (Just _))
97+ | name `elem` names = CppNoOp
98+ remRecLet cpp = cpp
99+ --
100+ tableItem :: Cpp -> (Text, Cpp)
101+ tableItem (CppVariableIntroduction (name, _) _ (Just body)) =
102+ (name, maybeRemCaps . addItemArg $ CppBlock [CppReturn body])
103+ where
104+ addItemArg :: Cpp -> Cpp
105+ addItemArg cpp = CppLambda [CaptureAll] [(tableName, constAnyRef)] (Just $ Any []) (CppBlock [CppReturn cpp])
106+ tableItem _ = error "not a variable introduction"
107+ --
108+ tableAccessor :: Text -> (Text, Cpp)
109+ tableAccessor name =
102110 ( name
103111 , CppApp
104112 (CppDataGet
105− (CppNumericLiteral . Left . fromIntegral . fromJust $ findIndex ((== name) . fst) fns)
106− dict')
107− [dict'])
113+ (CppNumericLiteral . Left . fromIntegral . fromJust $ findIndex ((== name) . fst) lets)
114+ (CppVar tableName))
115+ [CppVar tableName])
116+ --
117+ defines :: [Cpp]
118+ defines = def . tableAccessor . fst <$> lets
108119 where
109− dict' = CppVar dictname
110− accessor :: Text -> (Text, Cpp) -> Cpp
111− accessor dictname (name, _) =
112− CppVariableIntroduction (name, Just $ Any [Const]) [] (Just . snd $ accessed dictname name)
113− toelem :: Cpp -> (Text, Cpp)
114− toelem (CppFunction name args rtyp _ body'@(CppBlock body)) =
115− ( name
116− , withdict . maybeRemCaps $
117− CppLambda
118− [CaptureAll]
119− args
120− rtyp
121− (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))
122− toelem (CppVariableIntroduction (name, _) _ (Just body')) =
123− let replacements = accessed localdict . fst <$> filteredFns body'
124− replaced = everywhereOnCpp (replaceVar replacements) body'
125− in (name, withdict . maybeRemCaps $ CppBlock [CppReturn replaced])
126− toelem _ = error "not a function"
127− withdict :: Cpp -> Cpp
128− withdict cpp' =
129− maybeRemCaps $
130− CppLambda
131− [CaptureAll]
132− [(localdict, Just $ Any [Const, Ref])]
133− (Just $ Any [])
134− (CppBlock [CppReturn cpp'])
135− topdict :: Text
136− topdict = "_$dict$_"
137− localdict :: Text
138− localdict = "$dict$"
139−convertRecursiveRefs' cpps = cpps
120+ def (name, cpp) = CppRaw $ "#define " <> name <> " " <> P.prettyPrintCpp1 cpp <> "#"
121+ --
122+ undefines :: [Cpp]
123+ undefines = undef . tableAccessor . fst <$> lets
124+ where
125+ undef (name, _) = CppRaw $ "#undef " <> name <> "#"
126+ --
127+convertRecursive _ cpps = cpps