diff options
Diffstat (limited to 'src/LambdaCube/Compiler/Statements.hs')
-rw-r--r-- | src/LambdaCube/Compiler/Statements.hs | 12 |
1 files changed, 6 insertions, 6 deletions
diff --git a/src/LambdaCube/Compiler/Statements.hs b/src/LambdaCube/Compiler/Statements.hs index 42f02b07..1ce2beb6 100644 --- a/src/LambdaCube/Compiler/Statements.hs +++ b/src/LambdaCube/Compiler/Statements.hs | |||
@@ -49,7 +49,7 @@ mkLets_ mkLet = mkLets' mkLet . concatMap desugarMutual . sortDefs | |||
49 | 49 | ||
50 | mkLets' mkLet = f where | 50 | mkLets' mkLet = f where |
51 | f [] e = e | 51 | f [] e = e |
52 | f (Let n mt x: ds) e = mkLet n (maybe id (flip SAnn) mt (addFix n x)) (deBruijnify [n] $ f ds e) | 52 | f (StLet n mt x: ds) e = mkLet n (maybe id (flip SAnn) mt (addFix n x)) (deBruijnify [n] $ f ds e) |
53 | f (PrecDef{}: ds) e = f ds e | 53 | f (PrecDef{}: ds) e = f ds e |
54 | f (x: ds) e = error $ "mkLets: " ++ ppShow x | 54 | f (x: ds) e = error $ "mkLets: " ++ ppShow x |
55 | 55 | ||
@@ -57,7 +57,7 @@ addFix n x | |||
57 | | usedS n x = SBuiltin "primFix" `SAppV` SLamV (deBruijnify [n] x) | 57 | | usedS n x = SBuiltin "primFix" `SAppV` SLamV (deBruijnify [n] x) |
58 | | otherwise = x | 58 | | otherwise = x |
59 | 59 | ||
60 | addFix' (Let n nt nd) = Let n nt $ addFix n nd | 60 | addFix' (StLet n nt nd) = StLet n nt $ addFix n nd |
61 | addFix' x = x | 61 | addFix' x = x |
62 | 62 | ||
63 | type DefinedSet = Set.Set SName | 63 | type DefinedSet = Set.Set SName |
@@ -97,7 +97,7 @@ compileStmt compilegt ds = \case | |||
97 | -- , let ts = fst $ getParamsS $ up1 t | 97 | -- , let ts = fst $ getParamsS $ up1 t |
98 | , let as = [ funAlt m p $ noGuards {- -$ SLam Hidden (Wildcard SType) $ up1 -} $ SLet m' e $ sVar "cst" 0 | 98 | , let as = [ funAlt m p $ noGuards {- -$ SLam Hidden (Wildcard SType) $ up1 -} $ SLet m' e $ sVar "cst" 0 |
99 | | Instance n' i cstrs alts <- ds, n' == n | 99 | | Instance n' i cstrs alts <- ds, n' == n |
100 | , Let m' ~Nothing e <- alts, m' == m | 100 | , StLet m' ~Nothing e <- alts, m' == m |
101 | , let p = zip ((,) Hidden <$> ps) i ++ [((Hidden, Wildcard SType), PVarSimp $ dummyName "cst2")] | 101 | , let p = zip ((,) Hidden <$> ps) i ++ [((Hidden, Wildcard SType), PVarSimp $ dummyName "cst2")] |
102 | -- , let ic = patVars i | 102 | -- , let ic = patVars i |
103 | ] | 103 | ] |
@@ -113,7 +113,7 @@ compileStmt compilegt ds = \case | |||
113 | | n `elem` [n' | TypeFamily n' _ <- ds] -> return [] | 113 | | n `elem` [n' | TypeFamily n' _ <- ds] -> return [] |
114 | | otherwise -> do | 114 | | otherwise -> do |
115 | cf <- compilegt (SIName_ (mconcat [sourceInfo n | FunAlt n _ _ <- fs]) (nameFixity n) $ sName n) vs [gt | FunAlt _ _ gt <- fs] | 115 | cf <- compilegt (SIName_ (mconcat [sourceInfo n | FunAlt n _ _ <- fs]) (nameFixity n) $ sName n) vs [gt | FunAlt _ _ gt <- fs] |
116 | return [Let n (listToMaybe [t | TypeAnn n' t <- ds, n' == n]) cf] | 116 | return [StLet n (listToMaybe [t | TypeAnn n' t <- ds, n' == n]) cf] |
117 | fs -> fail $ "different number of arguments of " ++ sName n ++ ":\n" ++ show (vcat $ pShow . sourceInfo . snd . head <$> fs) | 117 | fs -> fail $ "different number of arguments of " ++ sName n ++ ":\n" ++ show (vcat $ pShow . sourceInfo . snd . head <$> fs) |
118 | [Stmt x] -> return [x] | 118 | [Stmt x] -> return [x] |
119 | where | 119 | where |
@@ -134,7 +134,7 @@ desugarValueDef p e = sequence | |||
134 | dns = reverse $ getPVars p | 134 | dns = reverse $ getPVars p |
135 | n = mangleNames dns | 135 | n = mangleNames dns |
136 | 136 | ||
137 | getLet (Let x Nothing (SRHS dx)) = Just (x, dx) | 137 | getLet (StLet x Nothing (SRHS dx)) = Just (x, dx) |
138 | getLet _ = Nothing | 138 | getLet _ = Nothing |
139 | 139 | ||
140 | fst' (x, _) = x -- TODO | 140 | fst' (x, _) = x -- TODO |
@@ -144,7 +144,7 @@ desugarMutual [x] = [x] | |||
144 | desugarMutual (traverse getLet -> Just (unzip -> (ns, ds))) = fst' $ runWriter $ do | 144 | desugarMutual (traverse getLet -> Just (unzip -> (ns, ds))) = fst' $ runWriter $ do |
145 | ss <- compileStmt' =<< desugarValueDef (foldr cHCons cHNil $ PVarSimp <$> ns) (SGlobal xy) | 145 | ss <- compileStmt' =<< desugarValueDef (foldr cHCons cHNil $ PVarSimp <$> ns) (SGlobal xy) |
146 | return $ | 146 | return $ |
147 | Let xy Nothing (addFix xy $ SRHS $ mkLets' SLet ss $ foldr HCons HNil ds) : ss | 147 | StLet xy Nothing (addFix xy $ SRHS $ mkLets' SLet ss $ foldr HCons HNil ds) : ss |
148 | where | 148 | where |
149 | xy = mangleNames ns | 149 | xy = mangleNames ns |
150 | desugarMutual xs = error "desugarMutual" | 150 | desugarMutual xs = error "desugarMutual" |