diff options
author | Csaba Hruska <csaba.hruska@gmail.com> | 2017-05-28 22:16:40 -0600 |
---|---|---|
committer | Csaba Hruska <csaba.hruska@gmail.com> | 2017-05-28 22:16:40 -0600 |
commit | 7fd48262bde5664d1c543a45be948e0f22d18bd7 (patch) | |
tree | 9e97d82c6feade4152835ab84f951cfba9475040 /src | |
parent | 233f1b8d67f3d5158792cb3f5b2cb17a03fdaf5b (diff) |
type signatures
Diffstat (limited to 'src')
-rw-r--r-- | src/LambdaCube/Compiler/DesugaredSource.hs | 72 |
1 files changed, 70 insertions, 2 deletions
diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs index 9e0949b0..fef5a1d5 100644 --- a/src/LambdaCube/Compiler/DesugaredSource.hs +++ b/src/LambdaCube/Compiler/DesugaredSource.hs | |||
@@ -33,6 +33,7 @@ type SName = String | |||
33 | pattern Ticked :: SName -> SName | 33 | pattern Ticked :: SName -> SName |
34 | pattern Ticked s = '\'': s | 34 | pattern Ticked s = '\'': s |
35 | 35 | ||
36 | untick :: SName -> SName | ||
36 | untick (Ticked s) = s | 37 | untick (Ticked s) = s |
37 | untick s = s | 38 | untick s = s |
38 | 39 | ||
@@ -99,6 +100,7 @@ instance PShow Range | |||
99 | : map text (drop (r - 1) $ take r' $ lines $ fileContent n) | 100 | : map text (drop (r - 1) $ take r' $ lines $ fileContent n) |
100 | ++ [text $ replicate (c - 1) ' ' ++ replicate (c' - c) '^' | r' == r] | 101 | ++ [text $ replicate (c - 1) ' ' ++ replicate (c' - c) '^' | r' == r] |
101 | 102 | ||
103 | showRangeWithoutFileName :: Range -> Doc | ||
102 | showRangeWithoutFileName (Range _ b e) = pShow b <> "-" <> pShow e | 104 | showRangeWithoutFileName (Range _ b e) = pShow b <> "-" <> pShow e |
103 | 105 | ||
104 | joinRange :: Range -> Range -> Range | 106 | joinRange :: Range -> Range -> Range |
@@ -111,6 +113,7 @@ data SI | |||
111 | = NoSI (Set.Set String) -- no source info, attached debug info | 113 | = NoSI (Set.Set String) -- no source info, attached debug info |
112 | | RangeSI Range | 114 | | RangeSI Range |
113 | 115 | ||
116 | getRange :: SI -> Maybe Range | ||
114 | getRange (RangeSI r) = Just r | 117 | getRange (RangeSI r) = Just r |
115 | getRange _ = Nothing | 118 | getRange _ = Nothing |
116 | 119 | ||
@@ -132,8 +135,10 @@ instance PShow SI where | |||
132 | hashPos :: FileInfo -> SPos -> Int | 135 | hashPos :: FileInfo -> SPos -> Int |
133 | hashPos fn (SPos_ p) = (1 + fileId fn) `shiftL` 32 .|. p | 136 | hashPos fn (SPos_ p) = (1 + fileId fn) `shiftL` 32 .|. p |
134 | 137 | ||
138 | debugSI :: String -> SI | ||
135 | debugSI a = NoSI (Set.singleton a) | 139 | debugSI a = NoSI (Set.singleton a) |
136 | 140 | ||
141 | validate :: SI -> [SI] -> SI | ||
137 | si@(RangeSI r) `validate` xs | r `notElem` [r | RangeSI r <- xs] = si | 142 | si@(RangeSI r) `validate` xs | r `notElem` [r | RangeSI r <- xs] = si |
138 | _ `validate` _ = mempty | 143 | _ `validate` _ = mempty |
139 | 144 | ||
@@ -155,9 +160,11 @@ class SetSourceInfo a where | |||
155 | 160 | ||
156 | data SIName = SIName__ { nameHash :: Int, nameSI :: SI, nameFixity :: Maybe Fixity, sName :: SName } | 161 | data SIName = SIName__ { nameHash :: Int, nameSI :: SI, nameFixity :: Maybe Fixity, sName :: SName } |
157 | 162 | ||
163 | pattern SIName_ :: SI -> Maybe Fixity -> SName -> SIName | ||
158 | pattern SIName_ si f n <- SIName__ _ si f n | 164 | pattern SIName_ si f n <- SIName__ _ si f n |
159 | where SIName_ si f n = SIName__ (fnameHash si n) si f n | 165 | where SIName_ si f n = SIName__ (fnameHash si n) si f n |
160 | 166 | ||
167 | pattern SIName_ :: SI -> SName -> SIName | ||
161 | pattern SIName si n <- SIName_ si _ n | 168 | pattern SIName si n <- SIName_ si _ n |
162 | where SIName si n = SIName_ si Nothing n | 169 | where SIName si n = SIName_ si Nothing n |
163 | 170 | ||
@@ -220,6 +227,7 @@ data FNameTag | |||
220 | | F_rhs | F_section | 227 | | F_rhs | F_section |
221 | deriving (Eq, Ord, Show, Enum, Bounded) | 228 | deriving (Eq, Ord, Show, Enum, Bounded) |
222 | 229 | ||
230 | tagName :: FNameTag -> String | ||
223 | tagName FCons = ":" | 231 | tagName FCons = ":" |
224 | tagName t = case show t of 'F': s -> s | 232 | tagName t = case show t of 'F': s -> s |
225 | 233 | ||
@@ -227,15 +235,19 @@ pattern Tag :: FNameTag -> SIName | |||
227 | pattern Tag t <- (toTag . nameHash -> Just t) | 235 | pattern Tag t <- (toTag . nameHash -> Just t) |
228 | where Tag t = SIName__ (fromEnum t) (tagSI t) (tagFixity t) (tagName t) | 236 | where Tag t = SIName__ (fromEnum t) (tagSI t) (tagFixity t) (tagName t) |
229 | 237 | ||
238 | pattern FTag :: FNameTag -> FName | ||
230 | pattern FTag t = FName (Tag t) | 239 | pattern FTag t = FName (Tag t) |
231 | 240 | ||
241 | toTag :: Int -> Maybe FNameTag | ||
232 | toTag i | 242 | toTag i |
233 | | i <= fromEnum (maxBound :: FNameTag) = Just (toEnum i) | 243 | | i <= fromEnum (maxBound :: FNameTag) = Just (toEnum i) |
234 | | otherwise = Nothing | 244 | | otherwise = Nothing |
235 | 245 | ||
246 | tagFixity :: FNameTag -> Maybe Fixity | ||
236 | tagFixity FCons = Just $ InfixR 5 | 247 | tagFixity FCons = Just $ InfixR 5 |
237 | tagFixity _ = Nothing | 248 | tagFixity _ = Nothing |
238 | 249 | ||
250 | tagSI :: FNameTag -> SI | ||
239 | tagSI t = NoSI $ Set.singleton $ tagName t | 251 | tagSI t = NoSI $ Set.singleton $ tagName t |
240 | 252 | ||
241 | fnameHash :: SI -> SName -> Int | 253 | fnameHash :: SI -> SName -> Int |
@@ -274,6 +286,7 @@ data SExp' a | |||
274 | | STyped a | 286 | | STyped a |
275 | deriving (Eq) | 287 | deriving (Eq) |
276 | 288 | ||
289 | sLHS :: SIName -> SExp' a -> SExp' a | ||
277 | sLHS _ (SRHS x) = x | 290 | sLHS _ (SRHS x) = x |
278 | sLHS n x = SLHS n x | 291 | sLHS n x = SLHS n x |
279 | 292 | ||
@@ -299,31 +312,57 @@ instance PShow Visibility where | |||
299 | Hidden -> "Hidden" | 312 | Hidden -> "Hidden" |
300 | Visible -> "Visible" | 313 | Visible -> "Visible" |
301 | 314 | ||
315 | dummyName :: String -> SIName | ||
302 | dummyName s = SIName (debugSI s) "" --("v_" ++ s) | 316 | dummyName s = SIName (debugSI s) "" --("v_" ++ s) |
317 | |||
318 | dummyName' :: String -> SData SIName | ||
303 | dummyName' = SData . dummyName | 319 | dummyName' = SData . dummyName |
320 | |||
321 | sVar :: String -> Int -> SExp' a | ||
304 | sVar = SVar . dummyName | 322 | sVar = SVar . dummyName |
305 | 323 | ||
324 | pattern SBind :: Binder -> SData SIName -> SExp' a -> SExp' a -> SExp' a | ||
306 | pattern SBind v x a b <- SBind_ _ v x a b | 325 | pattern SBind v x a b <- SBind_ _ v x a b |
307 | where SBind v x a b = SBind_ (sourceInfo a <> sourceInfo b) v x a b | 326 | where SBind v x a b = SBind_ (sourceInfo a <> sourceInfo b) v x a b |
327 | |||
328 | pattern SPi :: Visibility -> SExp' a -> SExp' a -> SExp' a | ||
308 | pattern SPi h a b <- SBind (BPi h) _ a b | 329 | pattern SPi h a b <- SBind (BPi h) _ a b |
309 | where SPi h a b = SBind (BPi h) (dummyName' "SPi") a b | 330 | where SPi h a b = SBind (BPi h) (dummyName' "SPi") a b |
331 | |||
332 | pattern SLam :: Visibility -> SExp' a -> SExp' a -> SExp' a | ||
310 | pattern SLam h a b <- SBind (BLam h) _ a b | 333 | pattern SLam h a b <- SBind (BLam h) _ a b |
311 | where SLam h a b = SBind (BLam h) (dummyName' "SLam") a b | 334 | where SLam h a b = SBind (BLam h) (dummyName' "SLam") a b |
335 | |||
336 | pattern Wildcard :: SExp' a -> SExp' a | ||
312 | pattern Wildcard t <- SBind BMeta _ t (SVar _ 0) | 337 | pattern Wildcard t <- SBind BMeta _ t (SVar _ 0) |
313 | where Wildcard t = SBind BMeta (dummyName' "Wildcard") t (sVar "Wildcard2" 0) | 338 | where Wildcard t = SBind BMeta (dummyName' "Wildcard") t (sVar "Wildcard2" 0) |
339 | |||
340 | pattern SLet :: SIName -> SExp' a -> SExp' a -> SExp' a | ||
314 | pattern SLet n a b <- SLet_ _ (SData n) a b | 341 | pattern SLet n a b <- SLet_ _ (SData n) a b |
315 | where SLet n a b = SLet_ (sourceInfo a <> sourceInfo b) (SData n) a b | 342 | where SLet n a b = SLet_ (sourceInfo a <> sourceInfo b) (SData n) a b |
343 | |||
344 | pattern SLamV :: SExp' a -> SExp' a | ||
316 | pattern SLamV a = SLam Visible (Wildcard SType) a | 345 | pattern SLamV a = SLam Visible (Wildcard SType) a |
346 | |||
347 | pattern SVar :: SIName -> Int -> SExp' a | ||
317 | pattern SVar a b = SVar_ (SData a) b | 348 | pattern SVar a b = SVar_ (SData a) b |
318 | 349 | ||
350 | pattern SApp :: Visibility -> SExp' a -> SExp' a -> SExp' a | ||
319 | pattern SApp h a b <- SApp_ _ h a b | 351 | pattern SApp h a b <- SApp_ _ h a b |
320 | where SApp h a b = SApp_ (sourceInfo a <> sourceInfo b) h a b | 352 | where SApp h a b = SApp_ (sourceInfo a <> sourceInfo b) h a b |
353 | |||
354 | pattern SAppH :: SExp' a -> SExp' a -> SExp' a | ||
321 | pattern SAppH a b = SApp Hidden a b | 355 | pattern SAppH a b = SApp Hidden a b |
356 | |||
357 | pattern SAppV :: SExp' a -> SExp' a -> SExp' a | ||
322 | pattern SAppV a b = SApp Visible a b | 358 | pattern SAppV a b = SApp Visible a b |
359 | |||
360 | pattern SAppV2 :: SExp' a -> SExp' a -> SExp' a -> SExp' a | ||
323 | pattern SAppV2 f a b = f `SAppV` a `SAppV` b | 361 | pattern SAppV2 f a b = f `SAppV` a `SAppV` b |
324 | 362 | ||
325 | infixl 2 `SAppV`, `SAppH` | 363 | infixl 2 `SAppV`, `SAppH` |
326 | 364 | ------------------------------------------------------------------------------------------------- **************************************** | |
365 | pattern SBuiltin :: FNameTag -> SExp' a | ||
327 | pattern SBuiltin s = SGlobal (Tag s) | 366 | pattern SBuiltin s = SGlobal (Tag s) |
328 | 367 | ||
329 | pattern SRHS a = SBuiltin F_rhs `SAppV` a | 368 | pattern SRHS a = SBuiltin F_rhs `SAppV` a |
@@ -332,9 +371,11 @@ pattern SType = SBuiltin F'Type | |||
332 | pattern SConstraint = SBuiltin F'Constraint | 371 | pattern SConstraint = SBuiltin F'Constraint |
333 | pattern Parens e = SBuiltin Fparens `SAppV` e | 372 | pattern Parens e = SBuiltin Fparens `SAppV` e |
334 | pattern SAnn a t = SBuiltin FtypeAnn `SAppH` t `SAppV` a | 373 | pattern SAnn a t = SBuiltin FtypeAnn `SAppH` t `SAppV` a |
335 | pattern TyType a = SAnn a SType | ||
336 | pattern SCW a = SBuiltin F'CW `SAppV` a | 374 | pattern SCW a = SBuiltin F'CW `SAppV` a |
337 | 375 | ||
376 | pattern TyType :: SExp' a -> SExp' a | ||
377 | pattern TyType a = SAnn a SType | ||
378 | |||
338 | -- builtin heterogenous list | 379 | -- builtin heterogenous list |
339 | pattern HList a = SBuiltin F'HList `SAppV` a | 380 | pattern HList a = SBuiltin F'HList `SAppV` a |
340 | pattern HCons a b = SBuiltin FHCons `SAppV` a `SAppV` b | 381 | pattern HCons a b = SBuiltin FHCons `SAppV` a `SAppV` b |
@@ -345,15 +386,19 @@ pattern BList a = SBuiltin F'List `SAppV` a | |||
345 | pattern BCons a b = SBuiltin FCons `SAppV` a `SAppV` b | 386 | pattern BCons a b = SBuiltin FCons `SAppV` a `SAppV` b |
346 | pattern BNil = SBuiltin FNil | 387 | pattern BNil = SBuiltin FNil |
347 | 388 | ||
389 | getTTuple :: SExp' a -> [SExp' a] | ||
348 | getTTuple (HList (getList -> Just xs)) = xs | 390 | getTTuple (HList (getList -> Just xs)) = xs |
349 | getTTuple x = [x] | 391 | getTTuple x = [x] |
350 | 392 | ||
393 | getList :: SExp' a -> Maybe [SExp' a] | ||
351 | getList BNil = Just [] | 394 | getList BNil = Just [] |
352 | getList (BCons x (getList -> Just y)) = Just (x:y) | 395 | getList (BCons x (getList -> Just y)) = Just (x:y) |
353 | getList _ = Nothing | 396 | getList _ = Nothing |
354 | 397 | ||
398 | sLit :: Lit -> SExp' a | ||
355 | sLit = SLit mempty | 399 | sLit = SLit mempty |
356 | 400 | ||
401 | isPi :: Binder -> Bool | ||
357 | isPi (BPi _) = True | 402 | isPi (BPi _) = True |
358 | isPi _ = False | 403 | isPi _ = False |
359 | 404 | ||
@@ -361,6 +406,7 @@ pattern UncurryS :: [(Visibility, SExp' a)] -> SExp' a -> SExp' a | |||
361 | pattern UncurryS ps t <- (getParamsS -> (ps, t)) | 406 | pattern UncurryS ps t <- (getParamsS -> (ps, t)) |
362 | where UncurryS ps t = foldr (uncurry SPi) t ps | 407 | where UncurryS ps t = foldr (uncurry SPi) t ps |
363 | 408 | ||
409 | getParamsS :: SExp' a -> ([(Visibility, SExp' a)], SExp' a) | ||
364 | getParamsS (SPi h t x) = first ((h, t):) $ getParamsS x | 410 | getParamsS (SPi h t x) = first ((h, t):) $ getParamsS x |
365 | getParamsS x = ([], x) | 411 | getParamsS x = ([], x) |
366 | 412 | ||
@@ -368,11 +414,13 @@ pattern AppsS :: SExp' a -> [(Visibility, SExp' a)] -> SExp' a | |||
368 | pattern AppsS f args <- (getApps -> (f, args)) | 414 | pattern AppsS f args <- (getApps -> (f, args)) |
369 | where AppsS = foldl $ \a (v, b) -> SApp v a b | 415 | where AppsS = foldl $ \a (v, b) -> SApp v a b |
370 | 416 | ||
417 | getApps :: SExp' a -> (SExp' a, [(Visibility, SExp' a)]) | ||
371 | getApps = second reverse . run where | 418 | getApps = second reverse . run where |
372 | run (SApp h a b) = second ((h, b):) $ run a | 419 | run (SApp h a b) = second ((h, b):) $ run a |
373 | run x = (x, []) | 420 | run x = (x, []) |
374 | 421 | ||
375 | -- todo: remove | 422 | -- todo: remove |
423 | downToS :: String -> Int -> Int -> [SExp' a] | ||
376 | downToS err n m = [sVar (err ++ "_" ++ show i) (n + i) | i <- [m-1, m-2..0]] | 424 | downToS err n m = [sVar (err ++ "_" ++ show i) (n + i) | i <- [m-1, m-2..0]] |
377 | 425 | ||
378 | instance SourceInfo (SExp' a) where | 426 | instance SourceInfo (SExp' a) where |
@@ -417,6 +465,7 @@ foldS h g f = fs | |||
417 | SLHS _ x -> fs i x | 465 | SLHS _ x -> fs i x |
418 | STyped x -> h i x | 466 | STyped x -> h i x |
419 | 467 | ||
468 | foldName :: Monoid m => (SIName -> m) -> SExp' Void -> m | ||
420 | foldName f = foldS (\_ -> elimVoid) (\sn _ -> f sn) mempty 0 | 469 | foldName f = foldS (\_ -> elimVoid) (\sn _ -> f sn) mempty 0 |
421 | 470 | ||
422 | usedS :: SIName -> SExp -> Bool | 471 | usedS :: SIName -> SExp -> Bool |
@@ -485,19 +534,25 @@ instance (HasFreeVars a, PShow a) => PShow (SExp' a) where | |||
485 | SVar _ i -> shVar i | 534 | SVar _ i -> shVar i |
486 | SLit _ l -> pShow l | 535 | SLit _ l -> pShow l |
487 | 536 | ||
537 | shApp :: Visibility -> Doc -> Doc -> Doc | ||
488 | shApp Visible a b = DApp a b | 538 | shApp Visible a b = DApp a b |
489 | shApp Hidden a b = DApp a (DAt b) | 539 | shApp Hidden a b = DApp a (DAt b) |
490 | 540 | ||
541 | usedVar' :: HasFreeVars a => Int -> a -> x -> Maybe x | ||
491 | usedVar' a b s | usedVar a b = Just s | 542 | usedVar' a b s | usedVar a b = Just s |
492 | | otherwise = Nothing | 543 | | otherwise = Nothing |
493 | 544 | ||
545 | shLam :: Maybe String -> Binder -> Doc -> Doc -> Doc | ||
494 | shLam usedVar h a b = shLam_ usedVar h (Just a) b | 546 | shLam usedVar h a b = shLam_ usedVar h (Just a) b |
495 | 547 | ||
548 | simpleFo :: Doc -> Doc | ||
496 | simpleFo (DExpand x _) = x | 549 | simpleFo (DExpand x _) = x |
497 | simpleFo x = x | 550 | simpleFo x = x |
498 | 551 | ||
552 | shLam_ :: Maybe String -> Binder -> Maybe Doc -> Doc -> Doc | ||
499 | shLam_ Nothing (BPi Hidden) (Just ((simpleFo -> DText "'CW") `DApp` a)) b = DFreshName Nothing $ showContext (DUp 0 a) b | 553 | shLam_ Nothing (BPi Hidden) (Just ((simpleFo -> DText "'CW") `DApp` a)) b = DFreshName Nothing $ showContext (DUp 0 a) b |
500 | where | 554 | where |
555 | showContext :: Doc -> Doc -> Doc | ||
501 | showContext x (DFreshName u d) = DFreshName u $ showContext (DUp 0 x) d | 556 | showContext x (DFreshName u d) = DFreshName u $ showContext (DUp 0 x) d |
502 | showContext x (DParContext xs y) = DParContext (DComma x xs) y | 557 | showContext x (DParContext xs y) = DParContext (DComma x xs) y |
503 | showContext x (DContext xs y) = DParContext (DComma x xs) y | 558 | showContext x (DContext xs y) = DParContext (DComma x xs) y |
@@ -505,6 +560,7 @@ shLam_ Nothing (BPi Hidden) (Just ((simpleFo -> DText "'CW") `DApp` a)) b = DFre | |||
505 | 560 | ||
506 | shLam_ usedVar h a b = DFreshName usedVar $ lam (p $ DUp 0 <$> a) b | 561 | shLam_ usedVar h a b = DFreshName usedVar $ lam (p $ DUp 0 <$> a) b |
507 | where | 562 | where |
563 | lam :: Doc -> Doc -> Doc | ||
508 | lam = case h of | 564 | lam = case h of |
509 | BPi Visible | 565 | BPi Visible |
510 | | isJust usedVar -> showForall "->" | 566 | | isJust usedVar -> showForall "->" |
@@ -514,33 +570,42 @@ shLam_ usedVar h a b = DFreshName usedVar $ lam (p $ DUp 0 <$> a) b | |||
514 | | otherwise -> showContext | 570 | | otherwise -> showContext |
515 | _ -> showLam | 571 | _ -> showLam |
516 | 572 | ||
573 | shAnn' :: Doc -> Maybe Doc -> Doc | ||
517 | shAnn' a = maybe a (shAnn a) | 574 | shAnn' a = maybe a (shAnn a) |
518 | 575 | ||
576 | p :: Maybe Doc -> Doc | ||
519 | p = case h of | 577 | p = case h of |
520 | BMeta -> shAnn' (blue $ DVar 0) | 578 | BMeta -> shAnn' (blue $ DVar 0) |
521 | BLam Hidden -> DAt . shAnn' (DVar 0) | 579 | BLam Hidden -> DAt . shAnn' (DVar 0) |
522 | BLam Visible -> shAnn' (DVar 0) | 580 | BLam Visible -> shAnn' (DVar 0) |
523 | _ -> ann | 581 | _ -> ann |
524 | 582 | ||
583 | ann :: Maybe Doc -> Doc | ||
525 | ann | isJust usedVar = shAnn' (DVar 0) | 584 | ann | isJust usedVar = shAnn' (DVar 0) |
526 | | otherwise = fromMaybe (text "Type") | 585 | | otherwise = fromMaybe (text "Type") |
527 | 586 | ||
587 | showForall :: String -> Doc -> Doc -> Doc | ||
528 | showForall s x (DFreshName u d) = DFreshName u $ showForall s (DUp 0 x) d | 588 | showForall s x (DFreshName u d) = DFreshName u $ showForall s (DUp 0 x) d |
529 | showForall s x (DForall s' xs y) | s == s' = DForall s (DSep (InfixR 11) x xs) y | 589 | showForall s x (DForall s' xs y) | s == s' = DForall s (DSep (InfixR 11) x xs) y |
530 | showForall s x y = DForall s x y | 590 | showForall s x y = DForall s x y |
531 | 591 | ||
592 | showContext :: Doc -> Doc -> Doc | ||
532 | showContext x y = DContext' x y | 593 | showContext x y = DContext' x y |
533 | 594 | ||
595 | showLam :: Doc -> Doc -> Doc | ||
534 | showLam x (DFreshName u d) = DFreshName u $ showLam (DUp 0 x) d | 596 | showLam x (DFreshName u d) = DFreshName u $ showLam (DUp 0 x) d |
535 | showLam x (DLam xs y) = DLam (DSep (InfixR 11) x xs) y | 597 | showLam x (DLam xs y) = DLam (DSep (InfixR 11) x xs) y |
536 | showLam x y = DLam x y | 598 | showLam x y = DLam x y |
537 | 599 | ||
600 | shLet :: Int -> Doc -> Doc -> Doc | ||
538 | shLet i a b = DLet' (DLet "=" (blue $ shVar i) $ DUp i a) (DUp i b) | 601 | shLet i a b = DLet' (DLet "=" (blue $ shVar i) $ DUp i a) (DUp i b) |
539 | 602 | ||
603 | showLet :: Doc -> Doc -> Doc | ||
540 | showLet x (DFreshName u d) = DFreshName u $ showLet (DUp 0 x) d | 604 | showLet x (DFreshName u d) = DFreshName u $ showLet (DUp 0 x) d |
541 | showLet x (DLet' xs y) = DLet' (DSemi x xs) y | 605 | showLet x (DLet' xs y) = DLet' (DSemi x xs) y |
542 | showLet x y = DLet' x y | 606 | showLet x y = DLet' x y |
543 | 607 | ||
608 | shLet_ :: Doc -> Doc -> Doc | ||
544 | shLet_ a b = DFreshName (Just "") $ showLet (DLet "=" (shVar 0) $ DUp 0 a) b | 609 | shLet_ a b = DFreshName (Just "") $ showLet (DLet "=" (shVar 0) $ DUp 0 a) b |
545 | 610 | ||
546 | -------------------------------------------------------------------------------- statement | 611 | -------------------------------------------------------------------------------- statement |
@@ -550,12 +615,15 @@ data Stmt | |||
550 | | Data SIName [(Visibility, SExp)]{-parameters-} SExp{-type-} [(SIName, SExp)]{-constructor names and types-} | 615 | | Data SIName [(Visibility, SExp)]{-parameters-} SExp{-type-} [(SIName, SExp)]{-constructor names and types-} |
551 | | PrecDef SIName Fixity | 616 | | PrecDef SIName Fixity |
552 | 617 | ||
618 | pattern StLet :: SIName -> Maybe (SExp' Void) -> SExp' Void -> Stmt | ||
553 | pattern StLet n mt x <- StmtLet n (getSAnn -> (x, mt)) | 619 | pattern StLet n mt x <- StmtLet n (getSAnn -> (x, mt)) |
554 | where StLet n mt x = StmtLet n $ maybe x (SAnn x) mt | 620 | where StLet n mt x = StmtLet n $ maybe x (SAnn x) mt |
555 | 621 | ||
622 | getSAnn :: SExp' a -> (SExp' a, Maybe (SExp' a)) | ||
556 | getSAnn (SAnn x t) = (x, Just t) | 623 | getSAnn (SAnn x t) = (x, Just t) |
557 | getSAnn x = (x, Nothing) | 624 | getSAnn x = (x, Nothing) |
558 | 625 | ||
626 | pattern Primitive :: SIName -> SExp' Void -> Stmt | ||
559 | pattern Primitive n t = StLet n (Just t) (SBuiltin Fundefined) | 627 | pattern Primitive n t = StLet n (Just t) (SBuiltin Fundefined) |
560 | 628 | ||
561 | instance PShow Stmt where | 629 | instance PShow Stmt where |