summaryrefslogtreecommitdiff
path: root/src/LambdaCube/Compiler/Statements.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/LambdaCube/Compiler/Statements.hs')
-rw-r--r--src/LambdaCube/Compiler/Statements.hs12
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
50mkLets' mkLet = f where 50mkLets' 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
60addFix' (Let n nt nd) = Let n nt $ addFix n nd 60addFix' (StLet n nt nd) = StLet n nt $ addFix n nd
61addFix' x = x 61addFix' x = x
62 62
63type DefinedSet = Set.Set SName 63type 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
137getLet (Let x Nothing (SRHS dx)) = Just (x, dx) 137getLet (StLet x Nothing (SRHS dx)) = Just (x, dx)
138getLet _ = Nothing 138getLet _ = Nothing
139 139
140fst' (x, _) = x -- TODO 140fst' (x, _) = x -- TODO
@@ -144,7 +144,7 @@ desugarMutual [x] = [x]
144desugarMutual (traverse getLet -> Just (unzip -> (ns, ds))) = fst' $ runWriter $ do 144desugarMutual (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
150desugarMutual xs = error "desugarMutual" 150desugarMutual xs = error "desugarMutual"