diff options
author | Csaba Hruska <csaba.hruska@gmail.com> | 2017-05-29 02:12:00 -0600 |
---|---|---|
committer | Csaba Hruska <csaba.hruska@gmail.com> | 2017-05-29 02:12:00 -0600 |
commit | b869dce24bebb8d7fd505f8b11b18b5eea82dc77 (patch) | |
tree | 93ae5fbd74da2db7d3801c641a6855949efe1fda /src | |
parent | ae21f6e3b50ce07e31bfde3ff55302aa812c2e7f (diff) |
type signatures
Diffstat (limited to 'src')
-rw-r--r-- | src/LambdaCube/Compiler/Statements.hs | 26 |
1 files changed, 21 insertions, 5 deletions
diff --git a/src/LambdaCube/Compiler/Statements.hs b/src/LambdaCube/Compiler/Statements.hs index 63a81b71..1755b57e 100644 --- a/src/LambdaCube/Compiler/Statements.hs +++ b/src/LambdaCube/Compiler/Statements.hs | |||
@@ -48,8 +48,10 @@ instance DeBruijnify SIName PreStmt where | |||
48 | mkLets :: [Stmt]{-where block-} -> SExp{-main expression-} -> SExp{-big let with lambdas; replaces global names with de bruijn indices-} | 48 | mkLets :: [Stmt]{-where block-} -> SExp{-main expression-} -> SExp{-big let with lambdas; replaces global names with de bruijn indices-} |
49 | mkLets = mkLets_ SLet | 49 | mkLets = mkLets_ SLet |
50 | 50 | ||
51 | mkLets_ :: DeBruijnify SIName a => (SIName -> SExp -> a -> a) -> [Stmt] -> a -> a | ||
51 | mkLets_ mkLet = mkLets' mkLet . concatMap desugarMutual . sortDefs | 52 | mkLets_ mkLet = mkLets' mkLet . concatMap desugarMutual . sortDefs |
52 | 53 | ||
54 | mkLets' :: DeBruijnify SIName a => (SIName -> SExp -> a -> a) -> [Stmt] -> a -> a | ||
53 | mkLets' mkLet = f where | 55 | mkLets' mkLet = f where |
54 | f [] e = e | 56 | f [] e = e |
55 | f (StmtLet n x: ds) e = mkLet n x (deBruijnify [n] $ f ds e) | 57 | f (StmtLet n x: ds) e = mkLet n x (deBruijnify [n] $ f ds e) |
@@ -61,8 +63,10 @@ type DefinedSet = Set.Set SName | |||
61 | addForalls :: DefinedSet -> SExp -> SExp | 63 | addForalls :: DefinedSet -> SExp -> SExp |
62 | addForalls defined x = foldl f x [v | v@(sName -> vh:_) <- reverse $ names x, sName v `notElem'` defined, isLower vh] | 64 | addForalls defined x = foldl f x [v | v@(sName -> vh:_) <- reverse $ names x, sName v `notElem'` defined, isLower vh] |
63 | where | 65 | where |
66 | f :: SExp -> SIName -> SExp | ||
64 | f e v = SPi Hidden (Wildcard SType) $ deBruijnify [v] e | 67 | f e v = SPi Hidden (Wildcard SType) $ deBruijnify [v] e |
65 | 68 | ||
69 | notElem' :: SName -> Set.Set SName -> Bool | ||
66 | notElem' s@(Ticked s') m = Set.notMember s m && Set.notMember s' m -- TODO: review | 70 | notElem' s@(Ticked s') m = Set.notMember s m && Set.notMember s' m -- TODO: review |
67 | notElem' s m = s `notElem` m | 71 | notElem' s m = s `notElem` m |
68 | 72 | ||
@@ -71,13 +75,16 @@ addForalls defined x = foldl f x [v | v@(sName -> vh:_) <- reverse $ names x, sN | |||
71 | 75 | ||
72 | ------------------------------------------------------------------------ | 76 | ------------------------------------------------------------------------ |
73 | 77 | ||
78 | compileStmt' :: MonadWriter [ParseCheck] m => [PreStmt] -> m [Stmt] | ||
74 | compileStmt' = compileStmt'_ SLHS SRHS SRHS | 79 | compileStmt' = compileStmt'_ SLHS SRHS SRHS |
75 | 80 | ||
81 | compileStmt'_ :: MonadWriter [ParseCheck] m => (SIName -> SExp -> SExp) -> (SExp -> SExp) -> (SExp -> SExp) -> [PreStmt] -> m [Stmt] | ||
76 | compileStmt'_ lhs ulend lend ds = fmap concat . sequence $ map (compileStmt lhs (\si vt -> compileGuardTree ulend lend (Just si) vt . mconcat) ds) $ groupBy h ds where | 82 | compileStmt'_ lhs ulend lend ds = fmap concat . sequence $ map (compileStmt lhs (\si vt -> compileGuardTree ulend lend (Just si) vt . mconcat) ds) $ groupBy h ds where |
83 | h :: PreStmt -> PreStmt -> Bool | ||
77 | h (FunAlt n _ _) (FunAlt m _ _) = m == n | 84 | h (FunAlt n _ _) (FunAlt m _ _) = m == n |
78 | h _ _ = False | 85 | h _ _ = False |
79 | 86 | ||
80 | --compileStmt :: MonadWriter [ParseCheck] m => (SIName -> [(Visibility, SExp)] -> [GuardTrees] -> m SExp) -> [PreStmt] -> [PreStmt] -> m [Stmt] | 87 | compileStmt :: MonadWriter [ParseCheck] m => (SIName -> SExp -> SExp) -> (SIName -> [(Visibility, SExp)] -> [GuardTrees] -> m SExp) -> [PreStmt] -> [PreStmt] -> m [Stmt] |
81 | compileStmt lhs compilegt ds = \case | 88 | compileStmt lhs compilegt ds = \case |
82 | [Instance{}] -> return [] | 89 | [Instance{}] -> return [] |
83 | [Class n ps ms] -> do | 90 | [Class n ps ms] -> do |
@@ -118,6 +125,7 @@ compileStmt lhs compilegt ds = \case | |||
118 | funAlt :: SIName -> [((Visibility, SExp), ParPat)] -> GuardTrees -> PreStmt | 125 | funAlt :: SIName -> [((Visibility, SExp), ParPat)] -> GuardTrees -> PreStmt |
119 | funAlt n pats gt = FunAlt n (fst <$> pats) $ compilePatts (map snd pats) gt | 126 | funAlt n pats gt = FunAlt n (fst <$> pats) $ compilePatts (map snd pats) gt |
120 | 127 | ||
128 | funAlt' :: SIName -> [(Visibility, SExp)] -> [ParPat] -> GuardTrees -> PreStmt | ||
121 | funAlt' n ts x gt = FunAlt n ts $ compilePatts x gt | 129 | funAlt' n ts x gt = FunAlt n ts $ compilePatts x gt |
122 | 130 | ||
123 | desugarValueDef :: MonadWriter [ParseCheck] m => ParPat -> SExp -> m [PreStmt] | 131 | desugarValueDef :: MonadWriter [ParseCheck] m => ParPat -> SExp -> m [PreStmt] |
@@ -127,9 +135,10 @@ desugarValueDef p e = sequence | |||
127 | | (i, x) <- zip [0..] dns | 135 | | (i, x) <- zip [0..] dns |
128 | ] | 136 | ] |
129 | where | 137 | where |
130 | dns = reverse $ getPVars p | 138 | dns = reverse $ getPVars p :: [SIName] |
131 | n = mangleNames dns | 139 | n = mangleNames dns :: SIName |
132 | 140 | ||
141 | getLet :: Stmt -> Maybe (SIName, SExp) | ||
133 | getLet (StmtLet x dx) = Just (x, dx) | 142 | getLet (StmtLet x dx) = Just (x, dx) |
134 | getLet _ = Nothing | 143 | getLet _ = Nothing |
135 | 144 | ||
@@ -149,10 +158,12 @@ desugarMutual (traverse getLet -> Just (unzip -> (ns, ds))) = fst' $ runWriter $ | |||
149 | xy = mangleNames ns | 158 | xy = mangleNames ns |
150 | desugarMutual xs = error "desugarMutual" | 159 | desugarMutual xs = error "desugarMutual" |
151 | 160 | ||
161 | addFix :: SIName -> SExp -> SExp | ||
152 | addFix n x | 162 | addFix n x |
153 | | usedS n x = SBuiltin FprimFix `SAppV` SLamV (deBruijnify [n] x) | 163 | | usedS n x = SBuiltin FprimFix `SAppV` SLamV (deBruijnify [n] x) |
154 | | otherwise = x | 164 | | otherwise = x |
155 | 165 | ||
166 | mangleNames :: [SIName] -> SIName | ||
156 | mangleNames xs = SIName (foldMap sourceInfo xs) $ "_" ++ intercalate "_" (sName <$> xs) | 167 | mangleNames xs = SIName (foldMap sourceInfo xs) $ "_" ++ intercalate "_" (sName <$> xs) |
157 | 168 | ||
158 | -------------------------------------------------------------------------------- statement with dependencies | 169 | -------------------------------------------------------------------------------- statement with dependencies |
@@ -167,25 +178,30 @@ data StmtNode = StmtNode | |||
167 | sortDefs :: [Stmt] -> [[Stmt]] | 178 | sortDefs :: [Stmt] -> [[Stmt]] |
168 | sortDefs xs = map snValue <$> scc snId snChildren snRevChildren nodes | 179 | sortDefs xs = map snValue <$> scc snId snChildren snRevChildren nodes |
169 | where | 180 | where |
181 | nodes :: [StmtNode] | ||
170 | nodes = zipWith mkNode [0..] xs | 182 | nodes = zipWith mkNode [0..] xs |
171 | where | 183 | where |
184 | mkNode :: Int -> Stmt -> StmtNode | ||
172 | mkNode i s = StmtNode i s (nubBy ((==) `on` snId) $ catMaybes $ (`Map.lookup` defMap) <$> need) | 185 | mkNode i s = StmtNode i s (nubBy ((==) `on` snId) $ catMaybes $ (`Map.lookup` defMap) <$> need) |
173 | (fromMaybe [] $ IM.lookup i revMap) | 186 | (fromMaybe [] $ IM.lookup i revMap) |
174 | where | 187 | where |
188 | need :: [SIName] | ||
175 | need = Set.toList $ case s of | 189 | need = Set.toList $ case s of |
176 | PrecDef{} -> mempty | 190 | PrecDef{} -> mempty |
177 | StLet _ mt e -> foldMap names mt <> names e | 191 | StLet _ mt e -> foldMap names mt <> names e |
178 | Data _ ps t cs -> foldMap (names . snd) ps <> names t <> foldMap (names . snd) cs | 192 | Data _ ps t cs -> foldMap (names . snd) ps <> names t <> foldMap (names . snd) cs |
179 | 193 | ||
194 | names :: SExp -> Set.Set SIName | ||
180 | names = foldName Set.singleton | 195 | names = foldName Set.singleton |
181 | 196 | ||
197 | revMap :: IM.IntMap [StmtNode] | ||
182 | revMap = IM.unionsWith (++) [IM.singleton (snId c) [n] | n <- nodes, c <- snChildren n] | 198 | revMap = IM.unionsWith (++) [IM.singleton (snId c) [n] | n <- nodes, c <- snChildren n] |
183 | 199 | ||
200 | defMap :: Map.Map SIName StmtNode | ||
184 | defMap = Map.fromList [(s, n) | n <- nodes, s <- def $ snValue n] | 201 | defMap = Map.fromList [(s, n) | n <- nodes, s <- def $ snValue n] |
185 | where | 202 | where |
203 | def :: Stmt -> [SIName] | ||
186 | def = \case | 204 | def = \case |
187 | PrecDef{} -> mempty | 205 | PrecDef{} -> mempty |
188 | StLet n _ _ -> [n] | 206 | StLet n _ _ -> [n] |
189 | Data n _ _ cs -> n: map fst cs | 207 | Data n _ _ cs -> n: map fst cs |
190 | |||
191 | |||