diff options
author | Péter Diviánszky <divipp@gmail.com> | 2016-05-13 23:05:19 +0200 |
---|---|---|
committer | Péter Diviánszky <divipp@gmail.com> | 2016-05-13 23:05:19 +0200 |
commit | 935e60f12569f521216b56d8acf01de721e5168e (patch) | |
tree | c5992970c67adf4b9b17a4f2fb5f87c0cc6b2743 /src/LambdaCube/Compiler/Statements.hs | |
parent | 8f2e602cada9141b653802cf1084b9bdfd6e0d06 (diff) |
refactoring
Diffstat (limited to 'src/LambdaCube/Compiler/Statements.hs')
-rw-r--r-- | src/LambdaCube/Compiler/Statements.hs | 20 |
1 files changed, 5 insertions, 15 deletions
diff --git a/src/LambdaCube/Compiler/Statements.hs b/src/LambdaCube/Compiler/Statements.hs index 3cd1edf1..2120efec 100644 --- a/src/LambdaCube/Compiler/Statements.hs +++ b/src/LambdaCube/Compiler/Statements.hs | |||
@@ -127,8 +127,7 @@ desugarValueDef p e = sequence | |||
127 | dns = reverse $ getPVars p | 127 | dns = reverse $ getPVars p |
128 | n = mangleNames dns | 128 | n = mangleNames dns |
129 | 129 | ||
130 | --getLet (StmtLet x dx) = Just (x, dx) | 130 | getLet (StmtLet x dx) = Just (x, dx) |
131 | getLet (StLet x mt dx) = Just (x, mt, dx) | ||
132 | getLet _ = Nothing | 131 | getLet _ = Nothing |
133 | 132 | ||
134 | fst' (x, _) = x -- TODO | 133 | fst' (x, _) = x -- TODO |
@@ -137,27 +136,18 @@ desugarMutual :: {-MonadWriter [ParseCheck] m => -} [Stmt] -> [Stmt] | |||
137 | desugarMutual [x@Primitive{}] = [x] | 136 | desugarMutual [x@Primitive{}] = [x] |
138 | desugarMutual [x@Data{}] = [x] | 137 | desugarMutual [x@Data{}] = [x] |
139 | desugarMutual [x@PrecDef{}] = [x] | 138 | desugarMutual [x@PrecDef{}] = [x] |
140 | desugarMutual [StLet n nt nd] = [StLet n nt $ addFix n nt nd] | 139 | desugarMutual [StLet n nt nd] = [StLet n nt $ addFix n nd] |
141 | --desugarMutual [StmtLet n nd] = [StmtLet n $ addFix n nd] | 140 | --desugarMutual [StmtLet n nd] = [StmtLet n $ addFix n nd] -- TODO |
142 | desugarMutual (traverse getLet -> Just (unzip3 -> (ns, ts, ds))) = fst' $ runWriter $ do | 141 | desugarMutual (traverse getLet -> Just (unzip -> (ns, ds))) = fst' $ runWriter $ do |
143 | --desugarMutual (traverse getLet -> Just (unzip -> (ns, ds))) = fst' $ runWriter $ do | ||
144 | ss <- compileStmt'_ sLHS SRHS SRHS =<< desugarValueDef (foldr cHCons cHNil $ PVarSimp <$> ns) (SGlobal xy) | 142 | ss <- compileStmt'_ sLHS SRHS SRHS =<< desugarValueDef (foldr cHCons cHNil $ PVarSimp <$> ns) (SGlobal xy) |
145 | return $ | 143 | return $ StmtLet xy (addFix xy $ mkLets' SLet ss $ foldr HCons HNil ds) : ss |
146 | -- StLet xy ty (addFix xy $ mkLets' SLet ss $ foldr HCons HNil ds) : ss | ||
147 | StLet xy ty (addFix xy ty $ mkLets' SLet ss $ foldr HCons HNil ds) : ss | ||
148 | 144 | ||
149 | where | 145 | where |
150 | ty = Nothing -- TODO: Just $ HList $ foldr BCons BNil $ const (Wildcard SType) <$> ts | ||
151 | xy = mangleNames ns | 146 | xy = mangleNames ns |
152 | desugarMutual xs = error "desugarMutual" | 147 | desugarMutual xs = error "desugarMutual" |
153 | 148 | ||
154 | addFix n nt x | ||
155 | | usedS n x = SBuiltin FprimFix `SAppV` SLam Visible (maybe (Wildcard SType) id nt) (deBruijnify [n] x) | ||
156 | |||
157 | {- | ||
158 | addFix n x | 149 | addFix n x |
159 | | usedS n x = SBuiltin FprimFix `SAppV` SLamV (deBruijnify [n] x) | 150 | | usedS n x = SBuiltin FprimFix `SAppV` SLamV (deBruijnify [n] x) |
160 | -} | ||
161 | | otherwise = x | 151 | | otherwise = x |
162 | 152 | ||
163 | mangleNames xs = SIName (foldMap sourceInfo xs) $ "_" ++ intercalate "_" (sName <$> xs) | 153 | mangleNames xs = SIName (foldMap sourceInfo xs) $ "_" ++ intercalate "_" (sName <$> xs) |